;;; -*-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
;;;
(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
;;; -*-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
;;;
(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)
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)
(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))
(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))
(define matcher-compilers
(make-eq-hash-table))
-
+\f
(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))))))
-\f
+ (WRAP-EXTERNAL-MATCHER ,test-expression)))
+
(define-atomic-matcher (char char)
`(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,char))
(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)))
+\f
(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)))
-\f
+ (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:
;;; -*-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
;;;
(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)
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)
(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
(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))
(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)))
-\f
(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))
(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))
+\f
+(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))
-\f
-(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)))))
+\f
(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:
;;; -*-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
;;;
(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*)
`(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))
+\f
+(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*)
+\f
+(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))
(define *parser-macros*
*global-parser-macros*)
\f
-;;;; 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)))
-\f
;;;; Code optimizer
(define (optimize-expression expression)
projects / mit-scheme.git / commitdiff