From 54e1e1f87eea3cd9f1c0c7ee2d1250db1070f4ee Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 26 Jun 2001 21:02:09 +0000 Subject: [PATCH] Lots of hair to allow explicit character-set specifications to be compiled at load time rather than at run time. --- v7/src/star-parser/matcher.scm | 166 +++++++++++++++------------------ v7/src/star-parser/parser.scm | 60 +++++------- v7/src/star-parser/shared.scm | 42 ++++++++- 3 files changed, 136 insertions(+), 132 deletions(-) diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index aae593170..aa91bb11d 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.2 2001/06/26 19:01:31 cph Exp $ +;;; $Id: matcher.scm,v 1.3 2001/06/26 21:02:04 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -38,24 +38,16 @@ (optimize-expression (generate-matcher-code expression)))) (define (generate-matcher-code expression) - (with-buffer-name - (lambda () - (with-canonical-matcher-expression expression - (lambda (expression) + (with-canonical-matcher-expression expression + (lambda (expression) + (with-buffer-name + (lambda () (compile-matcher-expression expression (no-pointers) (simple-backtracking-continuation `#T) (simple-backtracking-continuation `#F))))))) -;; COMPILE-MATCHER is called by the parser compiler, to generate code -;; to be embedded into a parser. - -(define (compile-matcher expression pointers if-succeed if-fail) - (with-canonical-matcher-expression expression - (lambda (expression) - (compile-matcher-expression expression pointers if-succeed if-fail)))) - (define (compile-matcher-expression expression pointers if-succeed if-fail) (cond ((and (pair? expression) (symbol? (car expression)) @@ -82,82 +74,78 @@ ;;;; Canonicalization (define (with-canonical-matcher-expression expression receiver) - (let ((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)))) - ((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))))) - ((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))))) - ((ALPHABET) - `(,(car expression) - ,(handle-complex-expression - (let ((arg (check-1-arg expression))) - (if (string? arg) - (if (string-prefix? "^" arg) - `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T) - `(RE-COMPILE-CHAR-SET ,arg #F)) - arg))))) - ((SEXP) - (handle-complex-expression (check-1-arg expression))) - (else - (error "Unknown matcher expression:" expression)))) - ((symbol? expression) - expression) - (else - (error "Unknown matcher expression:" expression)))) - - (define (check-1-arg expression) - (if (and (pair? (cdr expression)) - (null? (cddr expression))) - (cadr expression) - (error "Malformed expression:" expression))) - - (define (handle-complex-expression expression) - (if (or (char? expression) - (string? expression) - (symbol? expression)) - expression - (let loop ((bindings* bindings)) - (if (pair? bindings*) - (if (equal? expression (caar bindings*)) - (cdar bindings*) - (loop (cdr bindings*))) - (let ((variable (generate-uninterned-symbol))) - (set! bindings (cons (cons expression variable) bindings)) - variable))))) - - (let ((expression (do-expression expression))) - (if (pair? bindings) - `(LET ,(map (lambda (b) `(,(cdr b) ,(car b))) bindings) - ,(receiver expression)) - (receiver expression))))) + (let ((external-bindings (list 'BINDINGS)) + (internal-bindings (list 'BINDINGS))) + (let ((expression + (canonicalize-matcher-expression expression + external-bindings + internal-bindings))) + (maybe-make-let (map (lambda (b) (list (cdr b) (car b))) + (cdr external-bindings)) + (receiver + (maybe-make-let (map (lambda (b) (list (cdr b) (car b))) + (cdr internal-bindings)) + expression)))))) + +(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))))) + ((SEXP) + (handle-complex-expression (check-1-arg expression) + internal-bindings)) + (else + (error "Unknown matcher expression:" expression)))) + ((symbol? expression) + expression) + (else + (error "Unknown matcher expression:" expression)))) + (do-expression expression)) ;;;; Matchers diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index 3df8e8263..9c5c3bc89 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.2 2001/06/26 19:01:17 cph Exp $ +;;; $Id: parser.scm,v 1.3 2001/06/26 21:02:06 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -38,10 +38,10 @@ (optimize-expression (generate-parser-code expression)))) (define (generate-parser-code expression) - (with-buffer-name - (lambda () - (with-canonical-parser-expression expression - (lambda (expression) + (with-canonical-parser-expression expression + (lambda (expression) + (with-buffer-name + (lambda () (compile-parser-expression expression (no-pointers) @@ -80,7 +80,8 @@ ;;;; Canonicalization (define (with-canonical-parser-expression expression receiver) - (let ((bindings '())) + (let ((external-bindings (list 'BINDINGS)) + (internal-bindings (list 'BINDINGS))) (define (do-expression expression) (cond ((and (pair? expression) (symbol? (car expression)) @@ -101,49 +102,30 @@ (do-expression `(ALT ,(check-1-arg expression) (SEQ)))) ((MATCH NOISE) - (check-1-arg expression) - expression) + `(,(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)))) ((SEXP) - (let ((expression (check-1-arg expression))) - (if (symbol? expression) - expression - (let loop ((bindings* bindings)) - (if (pair? bindings*) - (if (equal? expression (caar bindings*)) - (cdar bindings*) - (loop (cdr bindings*))) - (let ((variable (generate-uninterned-symbol))) - (set! bindings - (cons (cons expression variable) bindings)) - variable)))))) + (handle-complex-expression (check-1-arg expression) + internal-bindings)) (else (error "Unknown parser expression:" expression)))) ((symbol? expression) expression) (else (error "Unknown parser expression:" expression)))) - - (define (check-1-arg expression) - (if (and (pair? (cdr expression)) - (null? (cddr expression))) - (cadr expression) - (error "Malformed expression:" expression))) - - (define (check-2-args expression) - (if (not (and (pair? (cdr expression)) - (pair? (cddr expression)) - (null? (cdddr expression)))) - (error "Malformed expression:" expression))) - (let ((expression (do-expression expression))) - (if (pair? bindings) - `(LET ,(map (lambda (b) `(,(cdr b) ,(car b))) bindings) - ,(receiver expression)) - (receiver expression))))) + (maybe-make-let (map (lambda (b) (list (cdr b) (car b))) + (cdr external-bindings)) + (receiver + (maybe-make-let (map (lambda (b) (list (cdr b) (car b))) + (cdr internal-bindings)) + expression)))))) ;;;; Parsers @@ -168,7 +150,7 @@ (define-parser (match matcher) (with-current-pointer pointers (lambda (start-pointers) - (compile-matcher matcher start-pointers + (compile-matcher-expression matcher start-pointers (lambda (pointers) (if-succeed pointers `(VECTOR (GET-PARSER-BUFFER-TAIL @@ -177,7 +159,7 @@ if-fail)))) (define-parser (noise matcher) - (compile-matcher matcher pointers + (compile-matcher-expression matcher pointers (lambda (pointers) (if-succeed pointers `(VECTOR))) if-fail)) diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm index c8571a300..848c045cc 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.2 2001/06/26 18:52:35 cph Exp $ +;;; $Id: shared.scm,v 1.3 2001/06/26 21:02:09 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -33,13 +33,47 @@ (define (with-variable-bindings expressions receiver) (let ((variables - (map (lambda (x) x (generate-uninterned-symbol)) expressions))) - `(LET ,(map list variables expressions) - ,(apply receiver variables)))) + (map (lambda (x) x (generate-uninterned-symbol)) + expressions))) + (maybe-make-let (map list variables expressions) + (apply receiver variables)))) (define (with-variable-binding expression receiver) (with-variable-bindings (list expression) receiver)) +(define (maybe-make-let bindings body) + (if (pair? bindings) + `(LET ,bindings ,body) + body)) + +(define (check-1-arg expression) + (if (and (pair? (cdr expression)) + (null? (cddr expression))) + (cadr expression) + (error "Malformed expression:" expression))) + +(define (check-2-args expression) + (if (not (and (pair? (cdr expression)) + (pair? (cddr expression)) + (null? (cdddr expression)))) + (error "Malformed expression:" expression))) + +(define (handle-complex-expression expression bindings) + (if (or (char? expression) + (string? expression) + (symbol? expression)) + expression + (let loop ((bindings* (cdr bindings))) + (if (pair? bindings*) + (if (equal? expression (caar bindings*)) + (cdar bindings*) + (loop (cdr bindings*))) + (let ((variable (generate-uninterned-symbol))) + (set-cdr! bindings + (cons (cons expression variable) + (cdr bindings))) + variable))))) + ;;;; Buffer pointers (define (no-pointers) -- 2.25.1