From: Chris Hanson Date: Tue, 16 Oct 2001 17:52:33 +0000 (+0000) Subject: Add code to reuse existing buffer pointers where possible. X-Git-Tag: 20090517-FFI~2497 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=53a880f6ba99db0227e897cb7b9059c2c8d3af55;p=mit-scheme.git Add code to reuse existing buffer pointers where possible. --- diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index 0afaf032f..d6bb09694 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.18 2001/10/16 16:41:08 cph Exp $ +;;; $Id: matcher.scm,v 1.19 2001/10/16 17:52:28 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -192,11 +192,11 @@ (generate-external-procedure expression preprocess-matcher-expression (lambda (expression) - `(,(compile-matcher-expression expression) + `(,(compile-matcher-expression expression #f) (LAMBDA (KF) KF #T) (LAMBDA () #F))))) -(define (compile-matcher-expression expression) +(define (compile-matcher-expression expression pointer) (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) @@ -206,7 +206,7 @@ (compiler (cdr entry))) (if (and arity (not (= (length (cdr expression)) arity))) (error "Incorrect arity for matcher:" expression)) - (apply compiler (cdr expression))))) + (apply compiler pointer (cdr expression))))) ((or (symbol? expression) (and (pair? expression) (eq? (car expression) 'SEXP))) (wrap-external-matcher @@ -220,7 +220,7 @@ (parameters (cdr form))) `(DEFINE-MATCHER-COMPILER ',name ,(if (symbol? parameters) `#F (length parameters)) - (LAMBDA ,parameters + (LAMBDA (POINTER . ,parameters) ,@compiler-body)))) (define (define-matcher-compiler keyword arity compiler) @@ -232,6 +232,7 @@ (define-macro (define-atomic-matcher form test-expression) `(DEFINE-MATCHER ,form + POINTER (WRAP-EXTERNAL-MATCHER ,test-expression))) (define-atomic-matcher (char char) @@ -262,6 +263,7 @@ `(NOT (PEEK-PARSER-BUFFER-CHAR ,*BUFFER-NAME*))) (define-matcher (discard-matched) + pointer (wrap-matcher (lambda (ks kf) `(BEGIN @@ -269,23 +271,23 @@ (,ks ,kf))))) (define-matcher (with-pointer identifier expression) - `(LET ((,identifier ,(fetch-pointer))) - ,(compile-matcher-expression expression))) + `(LET ((,identifier ,(or pointer (fetch-pointer)))) + ,(compile-matcher-expression expression (or pointer identifier)))) (define-matcher (seq . expressions) (if (pair? expressions) (if (pair? (cdr expressions)) (wrap-matcher (lambda (ks kf) - (let loop ((expressions expressions) (kf2 kf)) - `(,(compile-matcher-expression (car expressions)) + (let loop ((expressions expressions) (pointer pointer) (kf2 kf)) + `(,(compile-matcher-expression (car expressions) pointer) ,(if (pair? (cdr expressions)) (let ((kf3 (make-kf-identifier))) `(LAMBDA (,kf3) - ,(loop (cdr expressions) kf3))) + ,(loop (cdr expressions) #f kf3))) ks) ,kf2)))) - (compile-matcher-expression (car expressions))) + (compile-matcher-expression (car expressions) pointer)) (wrap-matcher (lambda (ks kf) `(,ks ,kf))))) (define-matcher (alt . expressions) @@ -293,21 +295,27 @@ (if (pair? (cdr expressions)) (wrap-matcher (lambda (ks kf) - (let loop ((expressions expressions)) - `(,(compile-matcher-expression (car expressions)) + (let loop ((expressions expressions) (pointer pointer)) + `(,(compile-matcher-expression (car expressions) pointer) ,ks ,(if (pair? (cdr expressions)) - (backtracking-kf (loop (cdr expressions))) + (backtracking-kf pointer + (lambda (pointer) + (loop (cdr expressions) pointer))) kf))))) - (compile-matcher-expression (car expressions))) + (compile-matcher-expression (car expressions) pointer)) (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf)))))) (define-matcher (* expression) + pointer (wrap-matcher (lambda (ks kf) (let ((ks2 (make-ks-identifier)) (kf2 (make-kf-identifier))) `(LET ,ks2 ((,kf2 ,kf)) - (,(compile-matcher-expression expression) + (,(compile-matcher-expression expression #f) ,ks2 - ,(backtracking-kf `(,ks ,kf2)))))))) \ No newline at end of file + ,(backtracking-kf #f + (lambda (pointer) + pointer + `(,ks ,kf2))))))))) \ No newline at end of file diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index 7b4898b32..a79baca0f 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.21 2001/10/16 16:41:10 cph Exp $ +;;; $Id: parser.scm,v 1.22 2001/10/16 17:52:31 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -181,11 +181,11 @@ (generate-external-procedure expression preprocess-parser-expression (lambda (expression) - `(,(compile-parser-expression expression) + `(,(compile-parser-expression expression #f) (LAMBDA (V KF) KF V) (LAMBDA () #F))))) -(define (compile-parser-expression expression) +(define (compile-parser-expression expression pointer) (cond ((and (pair? expression) (symbol? (car expression)) (list? (cdr expression)) @@ -195,7 +195,7 @@ (compiler (cdr entry))) (if (and arity (not (= (length (cdr expression)) arity))) (error "Incorrect arity for parser:" expression)) - (apply compiler (cdr expression))))) + (apply compiler pointer (cdr expression))))) ((or (symbol? expression) (and (pair? expression) (eq? (car expression) 'SEXP))) (wrap-external-parser @@ -209,7 +209,7 @@ (parameters (cdr form))) `(DEFINE-PARSER-COMPILER ',name ,(if (symbol? parameters) `#F (length parameters)) - (LAMBDA ,parameters + (LAMBDA (POINTER . ,parameters) ,@compiler-body)))) (define (define-parser-compiler keyword arity compiler) @@ -222,48 +222,49 @@ (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)))))) + (call-with-pointer pointer + (lambda (p) + `(,(compile-matcher-expression expression p) + ,(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) + `(,(compile-matcher-expression expression pointer) ,(let ((kf2 (make-kf-identifier))) `(LAMBDA (,kf2) (,ks '#() ,kf2))) ,kf)))) (define-parser (values . expressions) + pointer (wrap-parser (lambda (ks kf) `(,ks (VECTOR ,@expressions) ,kf)))) (define-parser (transform transform expression) - (post-processed-parser expression + (post-processed-parser expression pointer (lambda (ks v kf) (handle-parser-value `(,transform ,v) ks kf)))) (define-parser (map transform expression) - (post-processed-parser expression + (post-processed-parser expression pointer (lambda (ks v kf) `(,ks (VECTOR-MAP ,transform ,v) ,kf)))) (define-parser (encapsulate transform expression) - (post-processed-parser expression + (post-processed-parser expression pointer (lambda (ks v kf) `(,ks (VECTOR (,transform ,v)) ,kf)))) -(define (post-processed-parser expression procedure) +(define (post-processed-parser expression pointer procedure) (wrap-parser (lambda (ks kf) - `(,(compile-parser-expression expression) + `(,(compile-parser-expression expression pointer) ,(let ((v (make-value-identifier)) (kf2 (make-kf-identifier))) `(LAMBDA (,v ,kf2) @@ -271,10 +272,11 @@ ,kf)))) (define-parser (with-pointer identifier expression) - `(LET ((,identifier ,(fetch-pointer))) - ,(compile-parser-expression expression))) + `(LET ((,identifier ,(or pointer (fetch-pointer)))) + ,(compile-parser-expression expression (or pointer identifier)))) (define-parser (discard-matched) + pointer (wrap-parser (lambda (ks kf) `(BEGIN @@ -286,17 +288,21 @@ (if (pair? (cdr expressions)) (wrap-parser (lambda (ks kf) - (let loop ((expressions expressions) (vs '()) (kf2 kf)) - `(,(compile-parser-expression (car expressions)) + (let loop + ((expressions expressions) + (pointer pointer) + (vs '()) + (kf2 kf)) + `(,(compile-parser-expression (car expressions) pointer) ,(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) + (loop (cdr expressions) #f vs kf3) `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3))))) ,kf2)))) - (compile-parser-expression (car expressions))) + (compile-parser-expression (car expressions) pointer)) (wrap-parser (lambda (ks kf) `(,ks '#() ,kf))))) (define-parser (alt . expressions) @@ -304,25 +310,31 @@ (if (pair? (cdr expressions)) (wrap-parser (lambda (ks kf) - (let loop ((expressions expressions)) - `(,(compile-parser-expression (car expressions)) + (let loop ((expressions expressions) (pointer pointer)) + `(,(compile-parser-expression (car expressions) pointer) ,ks ,(if (pair? (cdr expressions)) - (backtracking-kf (loop (cdr expressions))) + (backtracking-kf pointer + (lambda (pointer) + (loop (cdr expressions) pointer))) kf))))) (compile-parser-expression (car expressions))) (wrap-parser (lambda (ks kf) ks `(,kf))))) (define-parser (* expression) + pointer (wrap-parser (lambda (ks kf) (let ((ks2 (make-ks-identifier)) (v (make-value-identifier)) (kf2 (make-kf-identifier))) `(LET ,ks2 ((,v '#()) (,kf2 ,kf)) - (,(compile-parser-expression expression) + (,(compile-parser-expression expression #f) ,(let ((v2 (make-value-identifier)) (kf3 (make-kf-identifier))) `(LAMBDA (,v2 ,kf3) (,ks2 (VECTOR-APPEND ,v ,v2) ,kf3))) - ,(backtracking-kf `(,ks ,v ,kf2)))))))) \ No newline at end of file + ,(backtracking-kf #f + (lambda (pointer) + pointer + `(,ks ,v ,kf2))))))))) \ No newline at end of file diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm index 32f07ccdc..b5f6dc439 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.12 2001/10/16 16:41:13 cph Exp $ +;;; $Id: shared.scm,v 1.13 2001/10/16 17:52:33 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -78,20 +78,22 @@ `(LET ((,v ,expression)) ,(generator v)))) -(define (call-with-pointer procedure) - (let ((p (make-ptr-identifier))) - `(LET ((,p ,(fetch-pointer))) - ,(procedure p)))) +(define (call-with-pointer pointer procedure) + (if pointer + (procedure pointer) + (let ((p (make-ptr-identifier))) + `(LET ((,p ,(fetch-pointer))) + ,(procedure p))))) (define (fetch-pointer) `(GET-PARSER-BUFFER-POINTER ,*buffer-name*)) -(define (backtracking-kf body) - (call-with-pointer - (lambda (p) - `(LAMBDA () - (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p) - ,body)))) +(define (backtracking-kf pointer generate-body) + (call-with-pointer pointer + (lambda (p) + `(LAMBDA () + (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,p) + ,(generate-body p))))) (define (make-kf-identifier) (generate-identifier 'KF))