From: Chris Hanson Date: Mon, 15 Oct 2001 17:01:10 +0000 (+0000) Subject: Complete rewrite of output control structure. New structure supports X-Git-Tag: 20090517-FFI~2501 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1657b97e3179c585f434c4176e6462d985a42ec8;p=mit-scheme.git Complete rewrite of output control structure. New structure supports backtracking properly, doing greedy matching until a failure occurs, then backtracking arbitrarily deeply to find a way forward. --- diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm index ede5693d8..4cb2b87c2 100644 --- a/v7/src/star-parser/load.scm +++ b/v7/src/star-parser/load.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: load.scm,v 1.9 2001/10/04 16:52:12 cph Exp $ +;;; $Id: load.scm,v 1.10 2001/10/15 17:01:03 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -23,4 +23,4 @@ (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () (package/system-loader "parser" '() 'QUERY))) -(add-subsystem-identification! "*Parser" '(0 8)) \ No newline at end of file +(add-subsystem-identification! "*Parser" '(0 9)) \ No newline at end of file diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index 8f3419b72..a960adc6b 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.15 2001/10/09 16:02:43 cph Exp $ +;;; $Id: matcher.scm,v 1.16 2001/10/15 17:01:05 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -111,6 +111,14 @@ (lambda (expression) `(ALT ,expression (SEQ)))) +(define-*matcher-expander 'COMPLETE + (lambda (expression) + `(SEQ ,expression (END-OF-INPUT)))) + +(define-*matcher-expander 'TOP-LEVEL + (lambda (expression) + `(SEQ ,expression (DISCARD-MATCHED)))) + (define-matcher-preprocessor '(ALT SEQ) (lambda (expression external-bindings internal-bindings) `(,(car expression) @@ -119,54 +127,46 @@ internal-bindings) (car expression))))) -(define-matcher-preprocessor '(* COMPLETE) +(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) +(define-matcher-preprocessor '(CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI ALPHABET) (lambda (expression external-bindings internal-bindings) external-bindings internal-bindings (check-1-arg expression) expression)) -(define-matcher-preprocessor 'STRING - (lambda (expression external-bindings internal-bindings) - external-bindings internal-bindings - (let ((string (check-1-arg expression))) - (if (and (string? string) (fix:= (string-length string) 1)) - `(CHAR ,(string-ref string 0)) - expression)))) - -(define-matcher-preprocessor 'STRING-CI +(define-matcher-preprocessor '(STRING STRING-CI) (lambda (expression external-bindings internal-bindings) external-bindings internal-bindings (let ((string (check-1-arg expression))) (if (and (string? string) (fix:= (string-length string) 1)) - `(CHAR-CI ,(string-ref string 0)) + `(,(if (eq? (car expression) 'STRING) 'CHAR 'CHAR-CI) + ,(string-ref string 0)) expression)))) (define-matcher-preprocessor 'CHAR-SET (lambda (expression external-bindings internal-bindings) internal-bindings - `(,(car expression) - ,(handle-complex-expression - (let ((arg (check-1-arg expression))) - (if (string? arg) + (let ((arg (check-1-arg expression))) + (if (string? arg) + `(,(car expression) + ,(handle-complex-expression (if (string-prefix? "^" arg) `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T) `(RE-COMPILE-CHAR-SET ,arg #F)) - arg)) - external-bindings)))) + external-bindings)) + expression)))) -(define-matcher-preprocessor 'ALPHABET +(define-matcher-preprocessor '(END-OF-INPUT DISCARD-MATCHED) (lambda (expression external-bindings internal-bindings) - internal-bindings - `(,(car expression) - ,(handle-complex-expression (check-1-arg expression) - external-bindings)))) + external-bindings internal-bindings + (check-0-args expression) + expression)) (define-matcher-preprocessor 'WITH-POINTER (lambda (expression external-bindings internal-bindings) @@ -201,17 +201,13 @@ (lambda () (maybe-make-let (map (lambda (b) (list (cdr b) (car b))) (cdr internal-bindings)) - (call-with-unknown-pointer - (lambda (pointer) - (compile-isolated-matcher-expression expression - pointer)))))))))) + (call-with-pointer + (lambda (p) + `(,(compile-matcher-expression expression) + (LAMBDA (KF) KF #T) + ,(make-kf p #F))))))))))) -(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) +(define (compile-matcher-expression expression) (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) @@ -221,31 +217,22 @@ (compiler (cdr entry))) (if (and arity (not (= (length (cdr expression)) arity))) (error "Incorrect arity for matcher:" expression)) - (apply compiler pointer if-succeed if-fail - (if arity - (cdr expression) - (list (cdr expression))))))) + (apply compiler (cdr expression))))) ((or (symbol? expression) (and (pair? expression) (eq? (car expression) 'SEXP))) - (handle-pending-backtracking pointer - (lambda (pointer) - `(IF (,(if (pair? expression) (cadr expression) expression) - ,*buffer-name*) - ,(call-with-unknown-pointer if-succeed) - ,(if-fail pointer))))) + (wrap-external-matcher + `(,(if (pair? expression) (cadr expression) expression) + ,*buffer-name*))) (else (error "Malformed matcher:" expression)))) (define-macro (define-matcher form . compiler-body) (let ((name (car form)) (parameters (cdr form))) - (if (symbol? parameters) - `(DEFINE-MATCHER-COMPILER ',name #F - (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,parameters) - ,@compiler-body)) - `(DEFINE-MATCHER-COMPILER ',name ,(length parameters) - (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,@parameters) - ,@compiler-body))))) + `(DEFINE-MATCHER-COMPILER ',name + ,(if (symbol? parameters) `#F (length parameters)) + (LAMBDA ,parameters + ,@compiler-body)))) (define (define-matcher-compiler keyword arity compiler) (hash-table/put! matcher-compilers keyword (cons arity compiler)) @@ -253,15 +240,11 @@ (define matcher-compilers (make-eq-hash-table)) - + (define-macro (define-atomic-matcher form test-expression) `(DEFINE-MATCHER ,form - (HANDLE-PENDING-BACKTRACKING POINTER - (LAMBDA (POINTER) - `(IF ,,test-expression - ,(CALL-WITH-UNKNOWN-POINTER IF-SUCCEED) - ,(IF-FAIL POINTER)))))) - + (WRAP-EXTERNAL-MATCHER ,test-expression))) + (define-atomic-matcher (char char) `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char)) @@ -286,64 +269,73 @@ (define-atomic-matcher (string-ci string) `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,string)) -(define-matcher (with-pointer identifier expression) - `(LET ((,identifier ,(pointer-reference pointer))) - ,(compile-matcher-expression expression pointer if-succeed if-fail))) - -(define-matcher (complete expression) - (compile-matcher-expression expression pointer - (lambda (pointer*) - `(IF (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*) - ,(if-fail (backtrack-to pointer pointer*)) - (BEGIN - (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*) - ,(if-succeed pointer*)))) - if-fail)) +(define-atomic-matcher (end-of-input) + `(NOT (PEEK-PARSER-BUFFER-CHAR ,*BUFFER-NAME*))) -(define-matcher (* expression) - if-fail - (handle-pending-backtracking pointer - (lambda (pointer) - 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))))) - ,(call-with-unknown-pointer if-succeed)))))) +(define-matcher (discard-matched) + (wrap-matcher + (lambda (ks kf) + `(BEGIN + (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*) + (,ks ,kf))))) +(define-matcher (with-pointer identifier expression) + `(LET ((,identifier ,(fetch-pointer))) + ,(compile-matcher-expression expression))) + (define-matcher (seq . expressions) - (let loop ((expressions expressions) (pointer* pointer)) - (if (pair? expressions) - (compile-matcher-expression (car expressions) pointer* - (lambda (pointer*) - (loop (cdr expressions) pointer*)) - (lambda (pointer*) - (if-fail (backtrack-to pointer pointer*)))) - (if-succeed pointer*)))) + (if (pair? expressions) + (if (pair? (cdr expressions)) + (wrap-matcher + (lambda (ks kf) + (call-with-pointer + (lambda (p) + (let loop + ((expressions expressions) + (kf2 (make-kf p `(,kf)))) + `(,(compile-matcher-expression (car expressions)) + ,(if (pair? (cdr expressions)) + (let ((kf3 (make-kf-identifier))) + `(LAMBDA (,kf3) + ,(loop (cdr expressions) kf3))) + ks) + ,kf2)))))) + (compile-matcher-expression (car expressions))) + (wrap-matcher (lambda (ks kf) `(,ks ,kf))))) (define-matcher (alt . expressions) (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))) - + (wrap-matcher + (lambda (ks kf) + (call-with-pointer + (lambda (p) + (let loop ((expressions expressions)) + `(,(compile-matcher-expression (car expressions)) + ,ks + ,(if (pair? (cdr expressions)) + (make-kf p (loop (cdr expressions))) + kf))))))) + (compile-matcher-expression (car expressions))) + (wrap-matcher (lambda (ks kf) ks `(,kf))))) + +(define-matcher (* expression) + (wrap-matcher + (lambda (ks kf) + (call-with-pointer + (lambda (p) + (let ((ks2 (make-ks-identifier)) + (kf2 (make-kf-identifier))) + `(LET ,ks2 ((,kf2 ,(make-kf p `(,ks ,kf)))) + ,(call-with-pointer + (lambda (p2) + `(,(compile-matcher-expression expression) + ,(let ((kf3 (make-kf-identifier))) + `(LAMBDA (,kf3) + (,ks2 ,(make-kf p2 `(,ks ,kf3))))) + ,(make-kf p2 `(,ks ,kf2)))))))))))) + ;;; 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 4988a3df3..41c7236ab 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.18 2001/10/09 16:02:22 cph Exp $ +;;; $Id: parser.scm,v 1.19 2001/10/15 17:01:07 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -108,6 +108,14 @@ (lambda (expression) `(ALT ,expression (SEQ)))) +(define-*parser-expander 'COMPLETE + (lambda (expression) + `(SEQ ,expression (MATCH (END-OF-INPUT))))) + +(define-*parser-expander 'TOP-LEVEL + (lambda (expression) + `(SEQ ,expression (DISCARD-MATCHED)))) + (define-parser-preprocessor '(ALT SEQ) (lambda (expression external-bindings internal-bindings) `(,(car expression) @@ -116,7 +124,7 @@ internal-bindings) (car expression))))) -(define-parser-preprocessor '(* COMPLETE TOP-LEVEL) +(define-parser-preprocessor '* (lambda (expression external-bindings internal-bindings) `(,(car expression) ,(preprocess-parser-expression (check-1-arg expression) @@ -152,6 +160,12 @@ (check-1-arg expression) expression)) +(define-parser-preprocessor 'DISCARD-MATCHED + (lambda (expression external-bindings internal-bindings) + external-bindings internal-bindings + (check-0-args expression) + expression)) + (define-parser-preprocessor 'VALUES (lambda (expression external-bindings internal-bindings) external-bindings internal-bindings @@ -176,13 +190,13 @@ (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))))))))))) + (call-with-pointer + (lambda (p) + `(,(compile-parser-expression expression) + (LAMBDA (V KF) KF V) + ,(make-kf p #f))))))))))) -(define (compile-parser-expression expression pointer if-succeed if-fail) +(define (compile-parser-expression expression) (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) @@ -192,46 +206,22 @@ (compiler (cdr entry))) (if (and arity (not (= (length (cdr expression)) arity))) (error "Incorrect arity for parser:" expression)) - (apply compiler pointer if-succeed if-fail - (if arity - (cdr expression) - (list (cdr expression))))))) + (apply compiler (cdr expression))))) ((or (symbol? expression) (and (pair? expression) (eq? (car expression) 'SEXP))) - (handle-pending-backtracking pointer - (lambda (pointer) - (with-variable-binding - `(,(if (pair? expression) (cadr expression) expression) - ,*buffer-name*) - (lambda (result) - `(IF ,result - ,(call-with-unknown-pointer - (lambda (pointer) - (if-succeed pointer result))) - ,(if-fail pointer))))))) + (wrap-external-parser + `(,(if (pair? expression) (cadr expression) expression) + ,*buffer-name*))) (else - (error "Malformed matcher:" expression)))) + (error "Malformed parser:" expression)))) -(define (backtracking-succeed handler) - (lambda (pointer result) - (handle-pending-backtracking pointer - (lambda (pointer) - pointer - (handler result))))) - -(define simple-backtracking-succeed - (backtracking-succeed (lambda (result) result))) - (define-macro (define-parser form . compiler-body) (let ((name (car form)) (parameters (cdr form))) - (if (symbol? parameters) - `(DEFINE-PARSER-COMPILER ',name #F - (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,parameters) - ,@compiler-body)) - `(DEFINE-PARSER-COMPILER ',name ,(length parameters) - (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,@parameters) - ,@compiler-body))))) + `(DEFINE-PARSER-COMPILER ',name + ,(if (symbol? parameters) `#F (length parameters)) + (LAMBDA ,parameters + ,@compiler-body)))) (define (define-parser-compiler keyword arity compiler) (hash-table/put! parser-compilers keyword (cons arity compiler)) @@ -239,138 +229,127 @@ (define parser-compilers (make-eq-hash-table)) - -(define-parser (match matcher) - (compile-matcher-expression matcher pointer - (lambda (pointer*) - (with-variable-binding - `(VECTOR - (GET-PARSER-BUFFER-TAIL ,*buffer-name* - ,(pointer-reference pointer))) - (lambda (v) - (if-succeed pointer* v)))) - if-fail)) - -(define-parser (noise matcher) - (compile-matcher-expression matcher pointer - (lambda (pointer) (if-succeed pointer `(VECTOR))) - if-fail)) + +(define-parser (match expression) + (wrap-parser + (lambda (ks kf) + (call-with-pointer + (lambda (p) + `(,(compile-matcher-expression expression) + ,(let ((kf2 (make-kf-identifier))) + `(LAMBDA (,kf2) + (,ks (VECTOR (GET-PARSER-BUFFER-TAIL ,*buffer-name* ,p)) + ,kf2))) + ,kf)))))) + +(define-parser (noise expression) + (wrap-parser + (lambda (ks kf) + `(,(compile-matcher-expression expression) + ,(let ((kf2 (make-kf-identifier))) + `(LAMBDA (,kf2) + (,ks '#() ,kf2))) + ,kf)))) (define-parser (values . expressions) - if-fail - (if-succeed pointer `(VECTOR ,@expressions))) + (wrap-parser + (lambda (ks kf) + `(,ks (VECTOR ,@expressions) ,kf)))) (define-parser (transform transform expression) - (compile-parser-expression expression pointer - (lambda (pointer* result) - (with-variable-binding `(,transform ,result) - (lambda (result) - `(IF ,result - ,(if-succeed pointer* result) - ,(if-fail (backtrack-to pointer pointer*)))))) - if-fail)) + (post-processed-parser expression + (lambda (ks v kf) + (handle-parser-value `(,transform ,v) ks kf)))) (define-parser (map transform expression) - (compile-parser-expression expression pointer - (lambda (pointer result) - (if-succeed pointer `(VECTOR-MAP ,transform ,result))) - if-fail)) + (post-processed-parser expression + (lambda (ks v kf) + `(,ks (VECTOR-MAP ,transform ,v) ,kf)))) (define-parser (encapsulate transform expression) - (compile-parser-expression expression pointer - (lambda (pointer result) - (if-succeed pointer `(VECTOR (,transform ,result)))) - if-fail)) - -(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*)) - (BEGIN - (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*) - ,(if-succeed pointer* result)))) - if-fail)) - -(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)) - -(define-parser (with-pointer identifier expression) - `(LET ((,identifier ,(pointer-reference pointer))) - ,(compile-parser-expression expression pointer - if-succeed if-fail))) - -(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)))))))) + (post-processed-parser expression + (lambda (ks v kf) + `(,ks (VECTOR (,transform ,v)) ,kf)))) + +(define (post-processed-parser expression procedure) + (wrap-parser + (lambda (ks kf) + `(,(compile-parser-expression expression) + ,(let ((v (make-value-identifier)) + (kf2 (make-kf-identifier))) + `(LAMBDA (,v ,kf2) + ,(procedure ks v kf2))) + ,kf)))) +(define-parser (with-pointer identifier expression) + `(LET ((,identifier ,(fetch-pointer))) + ,(compile-parser-expression expression))) + +(define-parser (discard-matched) + (wrap-parser + (lambda (ks kf) + `(BEGIN + (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*) + (,ks '#() ,kf))))) + (define-parser (seq . expressions) (if (pair? expressions) (if (pair? (cdr expressions)) - (let loop - ((expressions expressions) - (pointer* pointer) - (results '())) - (compile-parser-expression (car expressions) pointer* - (lambda (pointer* result) - (let ((results (cons result results))) - (if (pair? (cdr expressions)) - (loop (cdr expressions) pointer* results) - (if-succeed pointer* - `(VECTOR-APPEND ,@(reverse results)))))) - (lambda (pointer*) - (if-fail (backtrack-to pointer pointer*))))) - (compile-parser-expression (car expressions) pointer - if-succeed - if-fail)) - (if-succeed pointer `(VECTOR)))) + (wrap-parser + (lambda (ks kf) + (call-with-pointer + (lambda (p) + (let loop + ((expressions expressions) + (vs '()) + (kf2 (make-kf p `(,kf)))) + `(,(compile-parser-expression (car expressions)) + ,(let ((v (make-value-identifier)) + (kf3 (make-kf-identifier))) + `(LAMBDA (,v ,kf3) + ,(let ((vs (cons v vs))) + (if (pair? (cdr expressions)) + (loop (cdr expressions) vs kf3) + `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3))))) + ,kf2)))))) + (compile-parser-expression (car expressions))) + (wrap-parser (lambda (ks kf) `(,ks '#() ,kf))))) (define-parser (alt . expressions) (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))) + (wrap-parser + (lambda (ks kf) + (call-with-pointer + (lambda (p) + (let loop ((expressions expressions)) + `(,(compile-parser-expression (car expressions)) + ,ks + ,(if (pair? (cdr expressions)) + (make-kf p (loop (cdr expressions))) + kf))))))) + (compile-parser-expression (car expressions))) + (wrap-parser (lambda (ks kf) ks `(,kf))))) + +(define-parser (* expression) + (wrap-parser + (lambda (ks kf) + (let ((ks2 (make-ks-identifier)) + (kf2 (make-kf-identifier)) + (v (make-value-identifier))) + (call-with-pointer + (lambda (p) + `(LET ,ks2 ((,v '#()) (,kf2 ,(make-kf p `(,ks '#() ,kf)))) + ,(call-with-pointer + (lambda (p) + `(,(compile-parser-expression expression) + ,(let ((v2 (make-value-identifier)) + (kf3 (make-kf-identifier))) + `(LAMBDA (,v2 ,kf3) + (,ks2 (VECTOR-APPEND ,v ,v2) + ,(make-kf p `(,ks ,v ,kf3))))) + ,(make-kf p `(,ks ,v ,kf2)))))))))))) ;;; 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 4e475b5d5..485373a2c 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.9 2001/07/14 11:42:35 cph Exp $ +;;; $Id: shared.scm,v 1.10 2001/10/15 17:01:10 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -26,7 +26,8 @@ (define (with-buffer-name thunk) (let ((v (generate-uninterned-symbol))) `(LAMBDA (,v) - ,(fluid-let ((*buffer-name* v)) + ,(fluid-let ((*buffer-name* v) + (*id-counters* '())) (thunk))))) (define *buffer-name*) @@ -46,6 +47,83 @@ `(LET ,bindings ,body) body)) +(define (wrap-matcher generate-body) + (let ((ks (make-ks-identifier)) + (kf (make-kf-identifier))) + `(LAMBDA (,ks ,kf) + ,(generate-body ks kf)))) + +(define wrap-parser wrap-matcher) + +(define (wrap-external-matcher matcher) + (wrap-matcher + (lambda (ks kf) + `(IF ,matcher + (,ks ,kf) + (,kf))))) + +(define (wrap-external-parser expression) + (wrap-matcher + (lambda (ks kf) + (handle-parser-value expression ks kf)))) + +(define (handle-parser-value expression ks kf) + (with-value-binding expression + (lambda (v) + `(IF ,v + (,ks ,v ,kf) + (,kf))))) + +(define (with-value-binding expression generator) + (let ((v (make-value-identifier))) + `(LET ((,v ,expression)) + ,(generator v)))) + +(define (call-with-pointer procedure) + (let ((p (make-ptr-identifier))) + `(LET ((,p ,(fetch-pointer))) + ,(procedure p)))) + +(define (fetch-pointer) + `(GET-PARSER-BUFFER-POINTER ,*buffer-name*)) + +(define (make-kf p body) + `(LAMBDA () + (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p) + ,body)) + +(define (make-kf-identifier) + (generate-identifier 'KF)) + +(define (make-ks-identifier) + (generate-identifier 'KS)) + +(define (make-ptr-identifier) + (generate-identifier 'P)) + +(define (make-value-identifier) + (generate-identifier 'V)) + +(define (generate-identifier prefix) + (string->uninterned-symbol + (string-append + (symbol-name prefix) + (number->string + (let ((entry (assq prefix *id-counters*))) + (if entry + (let ((n (cdr entry))) + (set-cdr! entry (+ n 1)) + n) + (begin + (set! *id-counters* (cons (cons prefix 2) *id-counters*)) + 1))))))) + +(define *id-counters*) + +(define (check-0-args expression) + (if (not (null? (cdr expression))) + (error "Malformed expression:" expression))) + (define (check-1-arg expression #!optional predicate) (if (and (pair? (cdr expression)) (null? (cddr expression)) @@ -158,51 +236,6 @@ (define *parser-macros* *global-parser-macros*) -;;;; Buffer pointers - -(define (call-with-unknown-pointer procedure) - (let ((v.u (cons (generate-uninterned-symbol) #f))) - (let ((x (procedure (cons v.u #f)))) - (if (cdr v.u) - `(LET ((,(car v.u) (GET-PARSER-BUFFER-POINTER ,*buffer-name*))) - ,x) - x)))) - -(define (backtrack-to backtrack-pointer pointer) - ;; Specify that we want to backtrack to the position specified in - ;; BACKTRACK-POINTER. But don't actually change the position yet. - ;; Instead delay the move until it's actually needed. Without the - ;; 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 pointer) - (let ((p (or (cdr backtrack-pointer) (car backtrack-pointer)))) - (if (eq? (car pointer) p) - #f - p)))) - -(define (handle-pending-backtracking pointer procedure) - ;; Perform a pending backtracking operation, if any. - (if (cdr pointer) - (begin - (set-cdr! (cdr pointer) #t) - `(BEGIN - (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,(car (cdr pointer))) - ,(procedure (cons (cdr pointer) #f)))) - (procedure (cons (car pointer) #f)))) - -(define (simple-backtracking-continuation value) - (lambda (pointer) - (handle-pending-backtracking pointer - (lambda (pointer) - pointer - value)))) - -(define (pointer-reference pointer) - (let ((p (or (cdr pointer) (car pointer)))) - (set-cdr! p #t) - (car p))) - ;;;; Code optimizer (define (optimize-expression expression)