;;; -*-Scheme-*-
;;;
-;;; $Id: matcher.scm,v 1.19 2001/10/16 17:52:28 cph Exp $
+;;; $Id: matcher.scm,v 1.20 2001/11/09 21:37:53 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(optimize-expression (generate-matcher-code expression))))
(define (generate-matcher-code expression)
- (generate-external-procedure expression
- preprocess-matcher-expression
- (lambda (expression)
- `(,(compile-matcher-expression expression #f)
- (LAMBDA (KF) KF #T)
- (LAMBDA () #F)))))
-
-(define (compile-matcher-expression expression pointer)
+ (generate-external-procedure expression preprocess-matcher-expression
+ (lambda (expression)
+ (bind-delayed-lambdas
+ (lambda (ks kf) (compile-matcher-expression expression #f ks kf))
+ (make-matcher-ks-lambda (lambda (kf) kf `#T))
+ (make-kf-lambda (lambda () `#F))))))
+
+(define (compile-matcher-expression expression pointer ks kf)
(cond ((and (pair? expression)
(symbol? (car expression))
(list? (cdr expression))
(compiler (cdr entry)))
(if (and arity (not (= (length (cdr expression)) arity)))
(error "Incorrect arity for matcher:" expression))
- (apply compiler pointer (cdr expression)))))
+ (apply compiler pointer ks kf (cdr expression)))))
((or (symbol? expression)
(and (pair? expression) (eq? (car expression) 'SEXP)))
- (wrap-external-matcher
- `(,(if (pair? expression) (cadr expression) expression)
- ,*buffer-name*)))
+ (wrap-external-matcher `((PROTECT ,(if (pair? expression)
+ (cadr expression)
+ expression))
+ ,*buffer-name*)
+ ks
+ kf))
(else
(error "Malformed matcher:" expression))))
+(define (wrap-external-matcher matcher ks kf)
+ `(IF ,matcher
+ ,(delay-call ks kf)
+ ,(delay-call kf)))
+
(define-macro (define-matcher form . compiler-body)
(let ((name (car form))
(parameters (cdr form)))
`(DEFINE-MATCHER-COMPILER ',name
,(if (symbol? parameters) `#F (length parameters))
- (LAMBDA (POINTER . ,parameters)
+ (LAMBDA (POINTER KS KF . ,parameters)
,@compiler-body))))
(define (define-matcher-compiler keyword arity compiler)
(define-macro (define-atomic-matcher form test-expression)
`(DEFINE-MATCHER ,form
POINTER
- (WRAP-EXTERNAL-MATCHER ,test-expression)))
+ (WRAP-EXTERNAL-MATCHER ,test-expression KS KF)))
(define-atomic-matcher (char char)
- `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char))
+ `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* (PROTECT ,char)))
(define-atomic-matcher (char-ci char)
- `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* ,char))
+ `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* (PROTECT ,char)))
(define-atomic-matcher (not-char char)
- `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* ,char))
+ `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* (PROTECT ,char)))
(define-atomic-matcher (not-char-ci char)
- `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* ,char))
+ `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* (PROTECT ,char)))
(define-atomic-matcher (char-set char-set)
- `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name* ,char-set))
+ `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name* (PROTECT ,char-set)))
(define-atomic-matcher (alphabet alphabet)
- `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* ,alphabet))
+ `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* (PROTECT ,alphabet)))
(define-atomic-matcher (string string)
- `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,string))
+ `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* (PROTECT ,string)))
(define-atomic-matcher (string-ci string)
- `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,string))
+ `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* (PROTECT ,string)))
(define-atomic-matcher (end-of-input)
- `(NOT (PEEK-PARSER-BUFFER-CHAR ,*BUFFER-NAME*)))
+ `(NOT (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)))
(define-matcher (discard-matched)
pointer
- (wrap-matcher
- (lambda (ks kf)
- `(BEGIN
- (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
- (,ks ,kf)))))
+ `(BEGIN
+ (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
+ ,(delay-call ks kf)))
(define-matcher (with-pointer identifier expression)
- `(LET ((,identifier ,(or pointer (fetch-pointer))))
- ,(compile-matcher-expression expression (or pointer identifier))))
+ `((LAMBDA (,identifier)
+ ,(compile-matcher-expression expression identifier ks kf))
+ ,(fetch-pointer)))
\f
(define-matcher (seq . expressions)
(if (pair? expressions)
(if (pair? (cdr expressions))
- (wrap-matcher
- (lambda (ks kf)
- (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) #f kf3)))
- ks)
- ,kf2))))
- (compile-matcher-expression (car expressions) pointer))
- (wrap-matcher (lambda (ks kf) `(,ks ,kf)))))
+ (let loop ((expressions expressions) (pointer pointer) (kf kf))
+ (if (pair? (cdr expressions))
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-matcher-expression (car expressions)
+ pointer
+ ks
+ kf))
+ (make-matcher-ks-lambda
+ (lambda (kf)
+ (loop (cdr expressions) #f kf))))
+ (compile-matcher-expression (car expressions) pointer ks kf)))
+ (compile-matcher-expression (car expressions) pointer ks kf))
+ (delay-call ks kf)))
(define-matcher (alt . expressions)
(if (pair? expressions)
(if (pair? (cdr expressions))
- (wrap-matcher
- (lambda (ks kf)
- (let loop ((expressions expressions) (pointer pointer))
- `(,(compile-matcher-expression (car expressions) pointer)
- ,ks
- ,(if (pair? (cdr expressions))
- (backtracking-kf pointer
- (lambda (pointer)
- (loop (cdr expressions) pointer)))
- kf)))))
- (compile-matcher-expression (car expressions) pointer))
- (wrap-matcher (lambda (ks kf) `(BEGIN ,ks (,kf))))))
+ (let loop ((expressions expressions) (pointer pointer))
+ (if (pair? (cdr expressions))
+ (call-with-pointer pointer
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (kf)
+ (compile-matcher-expression (car expressions)
+ pointer
+ ks
+ kf))
+ (backtracking-kf pointer
+ (lambda ()
+ (loop (cdr expressions) pointer))))))
+ (compile-matcher-expression (car expressions) pointer ks kf)))
+ (compile-matcher-expression (car expressions) pointer ks kf))
+ (delay-call 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 #f)
- ,ks2
- ,(backtracking-kf #f
- (lambda (pointer)
- pointer
- `(,ks ,kf2)))))))))
\ No newline at end of file
+ (let ((ks2 (make-ks-identifier))
+ (kf2 (make-kf-identifier)))
+ `(LET ,ks2 ((,kf2 ,(delay-reference kf)))
+ ,(call-with-pointer #f
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (kf)
+ (compile-matcher-expression expression #f ks2 kf))
+ (backtracking-kf pointer
+ (lambda ()
+ (delay-call ks kf2)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.scm,v 1.22 2001/10/16 17:52:31 cph Exp $
+;;; $Id: parser.scm,v 1.23 2001/11/09 21:37:55 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(optimize-expression (generate-parser-code expression))))
(define (generate-parser-code expression)
- (generate-external-procedure expression
- preprocess-parser-expression
- (lambda (expression)
- `(,(compile-parser-expression expression #f)
- (LAMBDA (V KF) KF V)
- (LAMBDA () #F)))))
-
-(define (compile-parser-expression expression pointer)
+ (generate-external-procedure expression preprocess-parser-expression
+ (lambda (expression)
+ (bind-delayed-lambdas
+ (lambda (ks kf) (compile-parser-expression expression #f ks kf))
+ (make-parser-ks-lambda (lambda (v kf) kf v))
+ (make-kf-lambda (lambda () #f))))))
+
+(define (compile-parser-expression expression pointer ks kf)
(cond ((and (pair? expression)
(symbol? (car expression))
(list? (cdr expression))
(compiler (cdr entry)))
(if (and arity (not (= (length (cdr expression)) arity)))
(error "Incorrect arity for parser:" expression))
- (apply compiler pointer (cdr expression)))))
+ (apply compiler pointer ks kf (cdr expression)))))
((or (symbol? expression)
(and (pair? expression) (eq? (car expression) 'SEXP)))
- (wrap-external-parser
- `(,(if (pair? expression) (cadr expression) expression)
- ,*buffer-name*)))
+ (wrap-external-parser `((PROTECT ,(if (pair? expression)
+ (cadr expression)
+ expression))
+ ,*buffer-name*)
+ ks
+ kf))
(else
(error "Malformed parser:" expression))))
+(define (wrap-external-parser expression ks kf)
+ (with-value-binding expression
+ (lambda (v)
+ `(IF ,v
+ ,(delay-call ks v kf)
+ ,(delay-call kf)))))
+
(define-macro (define-parser form . compiler-body)
(let ((name (car form))
(parameters (cdr form)))
`(DEFINE-PARSER-COMPILER ',name
,(if (symbol? parameters) `#F (length parameters))
- (LAMBDA (POINTER . ,parameters)
+ (LAMBDA (POINTER KS KF . ,parameters)
,@compiler-body))))
(define (define-parser-compiler keyword arity compiler)
(make-eq-hash-table))
\f
(define-parser (match expression)
- (wrap-parser
- (lambda (ks 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))))))
+ (call-with-pointer pointer
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-matcher-expression expression pointer ks kf))
+ (make-matcher-ks-lambda
+ (lambda (kf)
+ (delay-call ks
+ `(VECTOR
+ (GET-PARSER-BUFFER-TAIL ,*buffer-name* ,pointer))
+ kf)))))))
(define-parser (noise expression)
- (wrap-parser
- (lambda (ks kf)
- `(,(compile-matcher-expression expression pointer)
- ,(let ((kf2 (make-kf-identifier)))
- `(LAMBDA (,kf2)
- (,ks '#() ,kf2)))
- ,kf))))
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-matcher-expression expression pointer ks kf))
+ (make-matcher-ks-lambda
+ (lambda (kf)
+ (delay-call ks `(VECTOR) kf)))))
(define-parser (values . expressions)
pointer
- (wrap-parser
- (lambda (ks kf)
- `(,ks (VECTOR ,@expressions) ,kf))))
+ (delay-call ks
+ `(VECTOR ,@(map (lambda (expression)
+ `(PROTECT ,expression))
+ expressions))
+ kf))
(define-parser (transform transform expression)
- (post-processed-parser expression pointer
+ (post-processed-parser expression pointer ks kf
(lambda (ks v kf)
- (handle-parser-value `(,transform ,v) ks kf))))
+ (wrap-external-parser `((PROTECT ,transform) ,v) ks kf))))
(define-parser (map transform expression)
- (post-processed-parser expression pointer
+ (post-processed-parser expression pointer ks kf
(lambda (ks v kf)
- `(,ks (VECTOR-MAP ,transform ,v) ,kf))))
+ (delay-call ks `(VECTOR-MAP (PROTECT ,transform) ,v) kf))))
(define-parser (encapsulate transform expression)
- (post-processed-parser expression pointer
+ (post-processed-parser expression pointer ks kf
(lambda (ks v kf)
- `(,ks (VECTOR (,transform ,v)) ,kf))))
-
-(define (post-processed-parser expression pointer procedure)
- (wrap-parser
- (lambda (ks kf)
- `(,(compile-parser-expression expression pointer)
- ,(let ((v (make-value-identifier))
- (kf2 (make-kf-identifier)))
- `(LAMBDA (,v ,kf2)
- ,(procedure ks v kf2)))
- ,kf))))
+ (delay-call ks `(VECTOR ((PROTECT ,transform) ,v)) kf))))
+
+(define (post-processed-parser expression pointer ks kf procedure)
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-parser-expression expression pointer ks kf))
+ (make-parser-ks-lambda
+ (lambda (v kf)
+ (procedure ks v kf)))))
(define-parser (with-pointer identifier expression)
- `(LET ((,identifier ,(or pointer (fetch-pointer))))
- ,(compile-parser-expression expression (or pointer identifier))))
+ `((LAMBDA (,identifier)
+ ,(compile-parser-expression expression identifier ks kf))
+ ,(fetch-pointer)))
(define-parser (discard-matched)
pointer
- (wrap-parser
- (lambda (ks kf)
- `(BEGIN
- (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
- (,ks '#() ,kf)))))
+ `(BEGIN
+ (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
+ ,(delay-call ks `(VECTOR) kf)))
\f
(define-parser (seq . expressions)
(if (pair? expressions)
(if (pair? (cdr expressions))
- (wrap-parser
- (lambda (ks kf)
- (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) #f vs kf3)
- `(,ks (VECTOR-APPEND ,@(reverse vs)) ,kf3)))))
- ,kf2))))
- (compile-parser-expression (car expressions) pointer))
- (wrap-parser (lambda (ks kf) `(,ks '#() ,kf)))))
+ (let loop
+ ((expressions expressions)
+ (pointer pointer)
+ (vs '())
+ (kf kf))
+ (bind-delayed-lambdas
+ (lambda (ks)
+ (compile-parser-expression (car expressions) pointer ks kf))
+ (make-parser-ks-lambda
+ (lambda (v kf)
+ (let ((vs (cons v vs)))
+ (if (pair? (cdr expressions))
+ (loop (cdr expressions) #f vs kf)
+ (delay-call ks `(VECTOR-APPEND ,@(reverse vs)) kf)))))))
+ (compile-parser-expression (car expressions) pointer ks kf))
+ (delay-call ks `(VECTOR) kf)))
(define-parser (alt . expressions)
(if (pair? expressions)
(if (pair? (cdr expressions))
- (wrap-parser
- (lambda (ks kf)
- (let loop ((expressions expressions) (pointer pointer))
- `(,(compile-parser-expression (car expressions) pointer)
- ,ks
- ,(if (pair? (cdr expressions))
- (backtracking-kf pointer
- (lambda (pointer)
- (loop (cdr expressions) pointer)))
- kf)))))
- (compile-parser-expression (car expressions)))
- (wrap-parser (lambda (ks kf) ks `(,kf)))))
+ (let loop ((expressions expressions) (pointer pointer))
+ (if (pair? (cdr expressions))
+ (call-with-pointer pointer
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (kf)
+ (compile-parser-expression (car expressions)
+ pointer
+ ks
+ kf))
+ (backtracking-kf pointer
+ (lambda ()
+ (loop (cdr expressions) pointer))))))
+ (compile-parser-expression (car expressions)
+ pointer
+ ks
+ kf)))
+ (compile-parser-expression (car expressions) ks kf))
+ (delay-call 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 #f)
- ,(let ((v2 (make-value-identifier))
- (kf3 (make-kf-identifier)))
- `(LAMBDA (,v2 ,kf3)
- (,ks2 (VECTOR-APPEND ,v ,v2) ,kf3)))
- ,(backtracking-kf #f
- (lambda (pointer)
- pointer
- `(,ks ,v ,kf2)))))))))
\ No newline at end of file
+ (let ((ks2 (make-ks-identifier))
+ (v (make-value-identifier))
+ (kf2 (make-kf-identifier)))
+ `(LET ,ks2 ((,v (VECTOR)) (,kf2 ,kf))
+ ,(call-with-pointer #f
+ (lambda (pointer)
+ (bind-delayed-lambdas
+ (lambda (ks kf)
+ (compile-parser-expression expression pointer ks kf))
+ (make-parser-ks-lambda
+ (lambda (v2 kf)
+ (delay-call ks2 `(VECTOR-APPEND ,v ,(delay-reference v2)) kf)))
+ (backtracking-kf pointer
+ (lambda ()
+ (delay-call ks v kf2)))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff