;;; -*-Scheme-*-
;;;
-;;; $Id: matcher.scm,v 1.8 2001/07/02 05:08:16 cph Exp $
+;;; $Id: matcher.scm,v 1.9 2001/07/02 12:14:29 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(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)))))))))
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (compile-matcher-expression expression pointer
+ (simple-backtracking-continuation `#T)
+ (simple-backtracking-continuation `#F)))))))))))
-(define (compile-matcher-expression expression pointers if-succeed if-fail)
+(define (compile-matcher-expression expression pointer if-succeed if-fail)
(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 pointers if-succeed if-fail
+ (apply compiler pointer if-succeed if-fail
(if arity
(cdr expression)
(list (cdr expression)))))))
((symbol? expression)
- (handle-pending-backtracking pointers
- (lambda (pointers)
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
`(IF (,expression ,*buffer-name*)
- ,(if-succeed (no-pointers))
- ,(if-fail pointers)))))
+ ,(call-with-unknown-pointer if-succeed)
+ ,(if-fail pointer)))))
(else
(error "Malformed matcher:" expression))))
(parameters (cdr form)))
(if (symbol? parameters)
`(DEFINE-MATCHER-COMPILER ',name #F
- (LAMBDA (POINTERS IF-SUCCEED IF-FAIL ,parameters)
+ (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,parameters)
,@compiler-body))
`(DEFINE-MATCHER-COMPILER ',name ,(length parameters)
- (LAMBDA (POINTERS IF-SUCCEED IF-FAIL ,@parameters)
+ (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,@parameters)
,@compiler-body)))))
(define (define-matcher-compiler keyword arity compiler)
(define-macro (define-atomic-matcher form test-expression)
`(DEFINE-MATCHER ,form
- (HANDLE-PENDING-BACKTRACKING POINTERS
- (LAMBDA (POINTERS)
+ (HANDLE-PENDING-BACKTRACKING POINTER
+ (LAMBDA (POINTER)
`(IF ,,test-expression
- ,(IF-SUCCEED (NO-POINTERS))
- ,(IF-FAIL POINTERS))))))
+ ,(CALL-WITH-UNKNOWN-POINTER IF-SUCCEED)
+ ,(IF-FAIL POINTER))))))
(define-atomic-matcher (char char)
`(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char))
`(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,string))
(define-matcher (with-pointer identifier expression)
- (with-current-pointer pointers
- (lambda (pointers)
- `(LET ((,identifier ,(current-pointer pointers)))
- ,(compile-matcher-expression expression pointers
- if-succeed if-fail)))))
+ `(LET ((,identifier ,(pointer-reference pointer)))
+ ,(compile-matcher-expression expression pointer if-succeed if-fail)))
\f
(define-matcher (* expression)
if-fail
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
- (let ((pointers (no-pointers))
- (v (generate-uninterned-symbol)))
- `(BEGIN
- (LET ,v ()
- ,(compile-matcher-expression expression pointers
- (simple-backtracking-continuation `(,v))
- (simple-backtracking-continuation `UNSPECIFIC)))
- ,(if-succeed pointers))))))
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ pointer
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (let ((v (generate-uninterned-symbol)))
+ `(BEGIN
+ (LET ,v ()
+ ,(compile-matcher-expression expression pointer
+ (simple-backtracking-continuation `(,v))
+ (simple-backtracking-continuation `UNSPECIFIC)))
+ ,(if-succeed pointer))))))))
(define-matcher (seq . expressions)
- (with-current-pointer pointers
- (lambda (start)
- (let loop
- ((expressions expressions)
- (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))))
- (if-succeed pointers))))))
+ (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*))))
(define-matcher (alt . expressions)
(cond ((not (pair? expressions))
- (if-fail pointers))
+ (if-fail pointer))
((not (pair? (cdr expressions)))
- (compile-matcher-expression expression pointers if-succeed if-fail))
+ (compile-matcher-expression expression pointer 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)))))))))
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ `(IF (OR ,@(map (let ((s (simple-backtracking-continuation '#T))
+ (f (simple-backtracking-continuation '#F)))
+ (lambda (expression)
+ (compile-matcher-expression expression pointer
+ s f)))
+ expressions))
+ ,(call-with-unknown-pointer if-succeed)
+ ,(if-fail pointer)))))))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
;;; -*-Scheme-*-
;;;
-;;; $Id: parser.scm,v 1.12 2001/07/02 05:08:19 cph Exp $
+;;; $Id: parser.scm,v 1.13 2001/07/02 12:14:32 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
(define (generate-parser-code expression)
(with-canonical-parser-expression expression
(lambda (expression)
- (compile-parser-expression
- expression
- (no-pointers)
- simple-backtracking-succeed
- (simple-backtracking-continuation `#F)))))
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (compile-parser-expression expression pointer
+ simple-backtracking-succeed
+ (simple-backtracking-continuation `#F)))))))
-(define (compile-parser-expression expression pointers if-succeed if-fail)
+(define (compile-parser-expression expression pointer if-succeed if-fail)
(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 pointers if-succeed if-fail
+ (apply compiler pointer if-succeed if-fail
(if arity
(cdr expression)
(list (cdr expression)))))))
((symbol? expression)
- (handle-pending-backtracking pointers
- (lambda (pointers)
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
(with-variable-binding `(,expression ,*buffer-name*)
(lambda (result)
`(IF ,result
- ,(if-succeed (no-pointers) result)
- ,(if-fail pointers)))))))
+ ,(call-with-unknown-pointer
+ (lambda (pointer)
+ (if-succeed pointer result)))
+ ,(if-fail pointer)))))))
(else
(error "Malformed matcher:" expression))))
(define (backtracking-succeed handler)
- (lambda (pointers result)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
+ (lambda (pointer result)
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ pointer
(handler result)))))
(define simple-backtracking-succeed
(parameters (cdr form)))
(if (symbol? parameters)
`(DEFINE-PARSER-COMPILER ',name #F
- (LAMBDA (POINTERS IF-SUCCEED IF-FAIL ,parameters)
+ (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,parameters)
,@compiler-body))
`(DEFINE-PARSER-COMPILER ',name ,(length parameters)
- (LAMBDA (POINTERS IF-SUCCEED IF-FAIL ,@parameters)
+ (LAMBDA (POINTER IF-SUCCEED IF-FAIL ,@parameters)
,@compiler-body)))))
(define (define-parser-compiler keyword arity compiler)
(make-eq-hash-table))
(define-parser (match matcher)
- (with-current-pointer pointers
- (lambda (start)
- (compile-matcher-expression matcher start
- (lambda (pointers)
- (with-variable-binding
- `(VECTOR
- (GET-PARSER-BUFFER-TAIL ,*buffer-name*
- ,(current-pointer start)))
- (lambda (v)
- (if-succeed pointers v))))
- if-fail))))
+ (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 pointers
- (lambda (pointers) (if-succeed pointers `(VECTOR)))
+ (compile-matcher-expression matcher pointer
+ (lambda (pointer) (if-succeed pointer `(VECTOR)))
if-fail))
(define-parser (default value parser)
if-fail
- (compile-parser-expression parser pointers if-succeed
- (lambda (pointers)
- (if-succeed pointers `(VECTOR ,value)))))
+ (compile-parser-expression parser pointer if-succeed
+ (lambda (pointer)
+ (if-succeed pointer `(VECTOR ,value)))))
\f
(define-parser (transform transform parser)
- (with-current-pointer 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))))))
- if-fail))))
+ (compile-parser-expression parser 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))
(define-parser (element-transform transform parser)
- (compile-parser-expression parser pointers
- (lambda (pointers result)
- (if-succeed pointers `(VECTOR-MAP ,transform ,result)))
+ (compile-parser-expression parser pointer
+ (lambda (pointer result)
+ (if-succeed pointer `(VECTOR-MAP ,transform ,result)))
if-fail))
(define-parser (encapsulate transform parser)
- (compile-parser-expression parser pointers
- (lambda (pointers result)
- (if-succeed pointers `(VECTOR (,transform ,result))))
+ (compile-parser-expression parser pointer
+ (lambda (pointer result)
+ (if-succeed pointer `(VECTOR (,transform ,result))))
if-fail))
(define-parser (complete parser)
- (with-current-pointer 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))
- (BEGIN
- (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
- ,(if-succeed pointers result))))
- if-fail))))
+ (compile-parser-expression parser 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 parser)
- (compile-parser-expression parser pointers
- (lambda (pointers result)
+ (compile-parser-expression parser pointer
+ (lambda (pointer result)
`(BEGIN
(DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
- ,(if-succeed pointers result)))
+ ,(if-succeed pointer result)))
if-fail))
(define-parser (with-pointer identifier expression)
- (with-current-pointer pointers
- (lambda (pointers)
- `(LET ((,identifier ,(current-pointer pointers)))
- ,(compile-parser-expression expression pointers
- if-succeed if-fail)))))
+ `(LET ((,identifier ,(pointer-reference pointer)))
+ ,(compile-parser-expression expression pointer
+ if-succeed if-fail)))
\f
-(define-parser (seq . ps)
- (if (pair? ps)
- (if (pair? (cdr ps))
- (with-current-pointer pointers
- (lambda (start)
- (let loop ((ps ps) (pointers start) (results '()))
- (compile-parser-expression (car ps) pointers
- (lambda (pointers result)
- (let ((results (cons result results)))
- (if (pair? (cdr ps))
- (loop (cdr ps) pointers results)
- (if-succeed pointers
- `(VECTOR-APPEND ,@(reverse results))))))
- (lambda (pointers)
- (if-fail (new-backtrack-pointer start pointers)))))))
- (compile-parser-expression (car ps) pointers if-succeed if-fail))
- (if-succeed pointers `(VECTOR))))
+(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))))
-(define-parser (alt . ps)
- (handle-pending-backtracking pointers
- (lambda (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 (alt . 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)))))))
(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)
- (backtracking-succeed
- (lambda (element)
- `(,loop (VECTOR-APPEND ,elements ,element))))
- (simple-backtracking-continuation elements))))
- (lambda (elements)
- (if-succeed (no-pointers) elements))))))
+ (handle-pending-backtracking pointer
+ (lambda (pointer)
+ pointer
+ (call-with-unknown-pointer
+ (lambda (pointer)
+ (with-variable-binding
+ (let ((loop (generate-uninterned-symbol))
+ (elements (generate-uninterned-symbol)))
+ `(LET ,loop ((,elements (VECTOR)))
+ ,(compile-parser-expression parser pointer
+ (backtracking-succeed
+ (lambda (element)
+ `(,loop (VECTOR-APPEND ,elements ,element))))
+ (simple-backtracking-continuation elements))))
+ (lambda (elements)
+ (if-succeed pointer elements))))))))
;;; Edwin Variables:
;;; Eval: (scheme-indent-method 'handle-pending-backtracking 1)
;;; -*-Scheme-*-
;;;
-;;; $Id: shared.scm,v 1.6 2001/07/02 05:08:22 cph Exp $
+;;; $Id: shared.scm,v 1.7 2001/07/02 12:14:35 cph Exp $
;;;
;;; Copyright (c) 2001 Massachusetts Institute of Technology
;;;
\f
;;;; Buffer pointers
-(define (no-pointers)
- ;; Initial pointer set, used only when we know nothing about the
- ;; context that an expression is expanding in.
- (cons #f #f))
-
-(define (with-current-pointer pointers procedure)
- ;; Get a pointer to the current position, if any. This is called
- ;; 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 (or (cdr pointers) (car pointers))
- (procedure pointers)
- (let ((v.u (cons (generate-uninterned-symbol) #f)))
- (let ((x (procedure (cons v.u (cdr pointers)))))
- (if (cdr v.u)
- `(LET ((,(car v.u) (GET-PARSER-BUFFER-POINTER ,*buffer-name*)))
- ,x)
- x)))))
-
-(define (current-pointer 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)
+(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-POINTERS. But don't actually change the position yet.
+ ;; 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 pointers)
- (if (eq? (car pointers) (car backtrack-pointers))
- #f
- (car backtrack-pointers))))
+ (cons (car pointer)
+ (let ((p (or (cdr pointer) (car pointer))))
+ (if (eq? (car pointer) (car backtrack-pointer))
+ #f
+ (car backtrack-pointer)))))
-(define (handle-pending-backtracking pointers procedure)
+(define (handle-pending-backtracking pointer procedure)
;; Perform a pending backtracking operation, if any.
- (if (cdr pointers)
+ (if (cdr pointer)
(begin
- (set-cdr! (cdr pointers) #t)
+ (set-cdr! (cdr pointer) #t)
`(BEGIN
- (SET-PARSER-BUFFER-POINTER! ,*buffer-name* ,(car (cdr pointers)))
- ,(procedure (cons (cdr pointers) #f))))
- (procedure (cons (car pointers) #f))))
+ (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 (pointers)
- (handle-pending-backtracking pointers
- (lambda (pointers)
- pointers
+ (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)))
\f
;;;; Code optimizer
projects / mit-scheme.git / commitdiff