From 00bdcd81e9fe8464440755267b7b6f49d104d5ed Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 2 Jul 2001 05:08:22 +0000 Subject: [PATCH] Rework handling of the pointers. There were some subtle bugs in the implementation that could have caused incorrect code generation. This code looks good but is still a bit confusing; I may not have it right yet. This code isn't yet tested. --- v7/src/star-parser/matcher.scm | 74 +++++++++++++------------ v7/src/star-parser/parser.scm | 98 +++++++++++++++++----------------- v7/src/star-parser/shared.scm | 27 +++++----- 3 files changed, 97 insertions(+), 102 deletions(-) diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index f1681bfa0..2e90c5b7d 100644 --- a/v7/src/star-parser/matcher.scm +++ b/v7/src/star-parser/matcher.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -50,11 +50,10 @@ (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) @@ -74,7 +73,7 @@ (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)))) @@ -201,7 +200,7 @@ (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) @@ -230,13 +229,14 @@ (lambda (pointers) `(LET ((,identifier ,(current-pointer pointers))) ,(compile-matcher-expression expression pointers - if-succeed if-fail))))) + if-succeed if-fail))))) (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 () @@ -247,43 +247,41 @@ (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: diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index 26e777f1d..71391cf76 100644 --- a/v7/src/star-parser/parser.scm +++ b/v7/src/star-parser/parser.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -43,11 +43,7 @@ (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) @@ -70,11 +66,21 @@ (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) @@ -184,13 +190,13 @@ (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)))) @@ -208,15 +214,14 @@ (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) @@ -233,11 +238,11 @@ (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)))) @@ -256,14 +261,14 @@ (lambda (pointers) `(LET ((,identifier ,(current-pointer pointers))) ,(compile-parser-expression expression pointers - if-succeed if-fail))))) + if-succeed if-fail))))) (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))) @@ -272,52 +277,45 @@ (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: diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm index cad7ea7f3..aab682e4c 100644 --- a/v7/src/star-parser/shared.scm +++ b/v7/src/star-parser/shared.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -100,7 +100,7 @@ ;; 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))))) @@ -110,15 +110,12 @@ 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 @@ -127,12 +124,14 @@ ;; 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 -- 2.25.1