#| -*-Scheme-*-

$Id: matcher.scm,v 1.35 2006/06/10 04:12:32 cph Exp $

Copyright 2001,2002,2004,2005,2006 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Pattern-matcher language

;;; A matcher is a procedure of one argument, a parser buffer.
;;; It performs a match against the contents of the buffer, starting
;;; at the location of the buffer pointer.  If the match is
;;; successful, the buffer pointer is advanced to the end of the
;;; matched segment, and #T is returned.  If the match fails, the
;;; buffer pointer is unchanged, and #F is returned.

(declare (usual-integrations))

;;;; Preprocessor

(define (preprocess-matcher-expression expression
				       external-bindings
				       internal-bindings)
  (cond ((and (pair? expression)
	      (symbol? (car expression))
	      (list? (cdr expression)))
	 (let ((preprocessor (matcher-preprocessor (car expression))))
	   (if preprocessor
	       (preprocessor expression external-bindings internal-bindings)
	       (error "Unknown matcher expression:" expression))))
	((symbol? expression)
	 (let ((preprocessor (matcher-preprocessor expression)))
	   (if preprocessor
	       (preprocessor expression external-bindings internal-bindings)
	       expression)))
	((identifier? expression)
	 expression)
	((string? expression)
	 (preprocess-matcher-expression `(STRING ,expression)
					external-bindings
					internal-bindings))
	((char? expression)
	 (preprocess-matcher-expression `(CHAR ,expression)
					external-bindings
					internal-bindings))
	(else
	 (error "Unknown matcher expression:" expression))))

(define (preprocess-matcher-expressions expressions
					external-bindings
					internal-bindings)
  (map (lambda (expression)
	 (preprocess-matcher-expression expression
					external-bindings
					internal-bindings))
       expressions))

(define (define-matcher-preprocessor name procedure)
  (if (pair? name)
      (for-each (lambda (name) (define-matcher-preprocessor name procedure))
		name)
      (hash-table/put! matcher-preprocessors name procedure))
  name)

(define-syntax define-*matcher-macro
  (rsc-macro-transformer
   (lambda (form environment)
     (let ((r-dme (close-syntax 'DEFINE-*MATCHER-EXPANDER environment))
	   (r-lambda (close-syntax 'LAMBDA environment)))
       (cond ((syntax-match? '(SYMBOL EXPRESSION) (cdr form))
	      `(,r-dme ',(cadr form)
		       (,r-lambda ()
				  ,(caddr form))))
	     ((syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
	      `(,r-dme ',(car (cadr form))
		       (,r-lambda ,(cdr (cadr form))
				  ,@(cddr form))))
	     (else
	      (ill-formed-syntax form)))))))

(define (define-*matcher-expander name procedure)
  (define-matcher-macro name
    (lambda (expression external-bindings internal-bindings)
      (preprocess-matcher-expression (if (pair? expression)
					 (apply procedure (cdr expression))
					 (procedure))
				     external-bindings
				     internal-bindings))))

(define (matcher-preprocessor name)
  (or (lookup-matcher-macro name)
      (hash-table/get matcher-preprocessors name #f)))

(define matcher-preprocessors
  (make-eq-hash-table))

(define-*matcher-expander '+
  (lambda (expression)
    `(SEQ ,expression (* ,expression))))

(define-*matcher-expander '?
  (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-expander 'N*
  (lambda (n expression)
    `(SEQ (N*N ,n ,expression)
	  (* ,expression))))

(define-*matcher-expander 'N*M
  (lambda (n m expression)
    `(SEQ (N*N ,n ,expression)
	  (*N ,(- m n) ,expression))))

(define-*matcher-expander 'ERROR
  (lambda (ptr msg . irritants)
    (let ((v (generate-uninterned-symbol)))
      `(SEXP (LAMBDA (,v)
	       ,@(if ptr (list v) '())
	       (PARSER-BUFFER-ERROR ,(or ptr v) ,msg ,@irritants))))))

(define-matcher-preprocessor '(ALT SEQ)
  (lambda (expression external-bindings internal-bindings)
    `(,(car expression)
      ,@(flatten-expressions (preprocess-matcher-expressions (cdr expression)
							     external-bindings
							     internal-bindings)
			     (car expression)))))

(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 '(N*N *N)
  (lambda (expression external-bindings internal-bindings)
    (check-n-args 2 expression
      (lambda (expression)
	(exact-nonnegative-integer? (cadr expression))))
    `(,(car expression) ,(cadr expression)
			,(preprocess-matcher-expression (caddr expression)
							external-bindings
							internal-bindings))))

(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 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))
	  `(,(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
    (let ((arg (check-1-arg expression)))
      (if (string? arg)
	  `(,(car expression)
	    ,(handle-complex-expression
	      (if (string-prefix? "^" arg)
		  `(,(close 'RE-COMPILE-CHAR-SET) ,(string-tail arg 1) #T)
		  `(,(close 'RE-COMPILE-CHAR-SET) ,arg #F))
	      external-bindings))
	  expression))))

(define-matcher-preprocessor '(END-OF-INPUT DISCARD-MATCHED)
  (lambda (expression external-bindings internal-bindings)
    external-bindings internal-bindings
    (check-0-args expression)
    expression))

(define-matcher-preprocessor 'WITH-POINTER
  (lambda (expression external-bindings internal-bindings)
    (check-2-args expression
		  (lambda (expression) (identifier? (cadr expression))))
    `(,(car expression) ,(cadr expression)
			,(preprocess-matcher-expression (caddr expression)
							external-bindings
							internal-bindings))))

(define-matcher-preprocessor 'SEXP
  (lambda (expression external-bindings internal-bindings)
    external-bindings internal-bindings
    (check-1-arg expression)
    expression))

;;;; Compiler

(define-syntax *matcher
  (sc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(EXPRESSION) (cdr form))
	 (generate-matcher-code (cadr form) environment)
	 (ill-formed-syntax form)))))

(define (generate-matcher-code expression environment)
  (generate-external-procedure expression environment
			       preprocess-matcher-expression
    (lambda (expression free-names)
      (call-with-pointer #f
	(lambda (p)
	  (bind-delayed-lambdas
	   (lambda (ks kf)
	     (compile-matcher-expression expression #f ks kf free-names))
	   (make-matcher-ks-lambda (lambda (kf) kf `#T))
	   (backtracking-kf p (lambda () `#F))))))))

(define (compile-matcher-expression expression pointer ks kf free-names)
  (cond ((and (pair? expression)
	      (symbol? (car expression))
	      (list? (cdr expression))
	      (hash-table/get matcher-compilers (car expression) #f))
	 => (lambda (entry)
	      (let ((arity (car entry))
		    (compiler (cdr entry)))
		(if (and arity (not (= (length (cdr expression)) arity)))
		    (error "Incorrect arity for matcher:" expression))
		(apply compiler pointer ks kf free-names (cdr expression)))))
	((or (identifier? expression)
	     (and (pair? expression) (eq? (car expression) 'SEXP)))
	 (wrap-external-matcher `(,(protect (if (pair? expression)
						(cadr expression)
						expression)
					    free-names)
				  ,*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-syntax define-matcher
  (rsc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
	 (let ((name (car (cadr form)))
	       (parameters (cdr (cadr form)))
	       (compiler-body (cddr form))
	       (r-dmc (close-syntax 'DEFINE-MATCHER-COMPILER environment))
	       (r-lambda (close-syntax 'LAMBDA environment)))
	   `(,r-dmc ',name
		    ,(if (identifier? parameters) `#F (length parameters))
		    (,r-lambda (POINTER KS KF FREE-NAMES . ,parameters)
			       ,@compiler-body)))
	 (ill-formed-syntax form)))))

(define (define-matcher-compiler keyword arity compiler)
  (hash-table/put! matcher-compilers keyword (cons arity compiler))
  keyword)

(define matcher-compilers
  (make-eq-hash-table))

(define-syntax define-atomic-matcher
  (rsc-macro-transformer
   (lambda (form environment)
     (if (syntax-match? '(DATUM + EXPRESSION) (cdr form))
	 (let ((r-dm (close-syntax 'DEFINE-MATCHER environment))
	       (r-wem (close-syntax 'WRAP-EXTERNAL-MATCHER environment)))
	   `(,r-dm ,(cadr form)
		   POINTER ,@(except-last-pair (cddr form))
		   (,r-wem ,(car (last-pair (cddr form))) KS KF)))
	 (ill-formed-syntax form)))))

(define-atomic-matcher (char char)
  `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,(protect char free-names)))

(define-atomic-matcher (char-ci char)
  `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* ,(protect char free-names)))

(define-atomic-matcher (not-char char)
  `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* ,(protect char free-names)))

(define-atomic-matcher (not-char-ci char)
  `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* ,(protect char free-names)))

(define-atomic-matcher (char-set char-set)
  `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name*
				    ,(protect char-set free-names)))

(define-atomic-matcher (alphabet alphabet)
  `(MATCH-PARSER-BUFFER-CHAR-IN-ALPHABET ,*buffer-name*
					 ,(protect alphabet free-names)))

(define-atomic-matcher (string string)
  `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,(protect string free-names)))

(define-atomic-matcher (string-ci string)
  `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,(protect string free-names)))

(define-atomic-matcher (end-of-input)
  free-names
  `(NOT (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)))

(define-matcher (discard-matched)
  pointer free-names
  `(BEGIN
     (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
     ,(delay-call ks kf)))

(define-matcher (with-pointer identifier expression)
  `((LAMBDA (,identifier)
      ,(compile-matcher-expression expression (or pointer identifier) ks kf
				   (cons identifier free-names)))
    ,(or pointer (fetch-pointer))))

(define-matcher (seq . expressions)
  (if (pair? expressions)
      (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
					   free-names))
	     (make-matcher-ks-lambda
	      (lambda (kf)
		(loop (cdr expressions) #f kf))))
	    (compile-matcher-expression (car expressions) pointer ks kf
					free-names)))
      (delay-call ks kf)))

(define-matcher (alt . expressions)
  (if (pair? expressions)
      (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
					       free-names))
		 (backtracking-kf pointer
		   (lambda ()
		     (loop (cdr expressions) pointer))))))
	    (compile-matcher-expression (car expressions) pointer ks kf
					free-names)))
      (delay-call kf)))

(define-matcher (* expression)
  pointer
  (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 free-names))
	     (backtracking-kf pointer
	       (lambda ()
		 (delay-call ks kf2)))))))))

(define-matcher (n*n n expression)
  (if (<= n 4)
      (open-code-n*n n expression pointer ks kf free-names)
      (close-code-n*n n expression pointer ks kf free-names)))

(define (open-code-n*n n expression pointer ks kf free-names)
  (let loop ((n n) (pointer pointer) (kf kf))
    (if (> n 0)
	(bind-delayed-lambdas
	 (lambda (ks)
	   (compile-matcher-expression expression pointer ks kf
				       free-names))
	 (make-matcher-ks-lambda
	  (lambda (kf)
	    (loop (- n 1) #f kf))))
	(delay-call ks kf))))

(define (close-code-n*n n expression pointer ks kf free-names)
  ;; Assume (>= N 1).
  pointer
  (let ((l1 (make-loop-identifier))
	(n1 (make-value-identifier))
	(kf2 (make-kf-identifier)))
    `(LET ,l1 ((,n1 ,n) (,kf2 ,(delay-reference kf)))
       (IF (> ,n1 1)
	   ,(bind-delayed-lambdas
	     (lambda (ks)
	       (compile-matcher-expression expression #f ks kf2 free-names))
	     (make-matcher-ks-lambda
	      (lambda (kf)
		`(,l1 (- ,n1 1) ,kf))))
	   ,(compile-matcher-expression expression #f ks kf2 free-names)))))

(define-matcher (*n n expression)
  (if (<= n 4)
      (open-code-*n n expression pointer ks kf free-names)
      (close-code-*n n expression pointer ks kf free-names)))

(define (open-code-*n n expression pointer ks kf free-names)
  (bind-delayed-lambdas
   (lambda (kf)
     (let loop ((n n) (pointer pointer) (kf kf))
       (if (> n 0)
	   (bind-delayed-lambdas
	    (lambda (ks)
	      (compile-matcher-expression expression pointer ks kf free-names))
	    (make-matcher-ks-lambda
	     (lambda (kf)
	       (loop (- n 1) #f kf))))
	   (delay-call ks kf))))
   (make-kf-lambda
    (lambda ()
      (delay-call ks kf)))))

(define (close-code-*n n expression pointer ks kf free-names)
  ;; Assume (>= N 1).
  pointer
  (bind-delayed-lambdas
   (lambda (kf)
     (let ((l1 (make-loop-identifier))
	   (n1 (make-value-identifier))
	   (kf2 (make-kf-identifier)))
       `(LET ,l1 ((,n1 ,n) (,kf2 ,(delay-reference kf)))
	  (IF (> ,n1 1)
	      ,(bind-delayed-lambdas
		(lambda (ks)
		  (compile-matcher-expression expression #f ks kf2 free-names))
		(make-matcher-ks-lambda
		 (lambda (kf)
		   `(,l1 (- ,n1 1) ,kf))))
	      ,(compile-matcher-expression expression #f ks kf2 free-names)))))
   (make-kf-lambda
    (lambda ()
      (delay-call ks kf)))))