;;; match.ss

;;; This program was originally designed and implemented by Dan
;;; Friedman.  It was redesigned and implemented by Erik Hilsdale;
;;; some improvements were suggested by Steve Ganz.  Additional
;;; modifications were made by Kent Dybvig. Original port to PLT Scheme
;;; by Matthew Flatt. As of 20020328, Matt Jadud is maintaining
;;; the PLT Scheme port of this code.

;;; Copyright (c) 1992-2002 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full.  This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.

;;; A complete CHANGELOG and some documentation can be found at the 
;;; end of this file.

;;; If you are reading this comment, then you do not have
;;; the most recent version of 'match'.

;; =============================================================

;; Exp    ::= (match              Exp Clause)
;;         || (trace-match        Exp Clause)
;;         || (match+       (Id*) Exp Clause*)
;;         || (trace-match+ (Id*) Exp Clause*)
;;         || OtherSchemeExp

;; Clause ::= (Pat Exp+) || (Pat (guard Exp*) Exp+)

;; Pat    ::= (Pat ... . Pat)
;;         || (Pat . Pat)
;;         || ()
;;         || #(Pat* Pat ... Pat*)
;;         || #(Pat*)
;;         || ,Id
;;         || ,[Id*]
;;         || ,[Cata -> Id*]
;;         || Id

;; Cata   ::= Exp

;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!)

#cs
(module iu-match mzscheme
  (provide match+ trace-match+ match trace-match )
  (require-for-syntax "iu-exptime.ss" (lib "stx.ss" "syntax"))
  (require (lib "list.ss") (lib "etc.ss") )
  ;; RRN: [2005.11.13]
  (require "cheztrace.ss")
  
  (define (make-list n v)
    (vector->list (make-vector n v)))


  (define match-equality-test
  (make-parameter
   equal?
   (lambda (x)
     (unless (procedure? x)
	     (error 'match-equality-test "~s is not a procedure" x))
     x)))
  
  (define-syntax match+
    (lambda (x)
      (syntax-case x ()
	[(_ (ThreadedId ...) Exp Clause ...)
	 #'(let f ((ThreadedId ThreadedId) ... (x Exp))
	     (match-help _ f x (ThreadedId ...) Clause ...))])))

  (define-syntax match
    (lambda (x)
      (syntax-case x ()
	[(_ Exp Clause ...)
	 #'(let f ((x Exp))
	     (match-help _ f x () Clause ...))])))

  (define-syntax trace-match+
    (lambda (x)
      (syntax-case x ()
	[(_ (ThreadedId ...) Name Exp Clause ...)
	 #'(letrec ((f (trace-lambda Name (ThreadedId ... x)
				     (match-help _ f x (ThreadedId ...) Clause ...))))
	     (f ThreadedId ... x))])))

  (define-syntax trace-match
    (lambda (x)
      (syntax-case x ()
	[(_ Name Exp Clause ...)
	 #'(letrec ((f (trace-lambda Name (x)
				     (match-help _ f x () Clause ...))))
	     (f Exp))])))

;;; ------------------------------

  (define-syntax let-values**
    (syntax-rules ()
      ((_ () B0 B ...) (begin B0 B ...))
      ((_ ((Formals Exp) Rest ...) B0 B ...)
       (let-values** (Rest ...) 
		     (call-with-values (lambda () Exp)
		       (lambda Formals B0 B ...))))))

  (define-syntax match-help
    (lambda (x)
      (syntax-case x ()
	((_ Template Cata Obj ThreadedIds)
	 #'(error 'match "Unmatched datum: ~s" Obj))
	((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...)
	 #'(convert-pat Pat
			(match-help1 Template Cata Obj ThreadedIds 
				     (B0 B ...)
				     Rest ...))))))

  (define-syntax match-help1
    (syntax-rules (guard)
      ((_ PatLit Vars Cdecls Template Cata Obj ThreadedIds
	  ((guard G ...) B0 B ...) Rest ...)
       (let ((ls/false (sexp-dispatch Obj PatLit)))
	 (if (and ls/false (apply (lambda Vars
				    (guard-body Cdecls
						(extend-backquote Template (and G ...))))
				  ls/false))
	     (apply (lambda Vars
		      (clause-body Cata Cdecls ThreadedIds
				   (extend-backquote Template B0 B ...)))
		    ls/false)
	     (match-help Template Cata Obj ThreadedIds Rest ...))))
      ((_ PatLit Vars Cdecls Template Cata Obj ThreadedIds
	  (B0 B ...) Rest ...)
       (let ((ls/false (sexp-dispatch Obj PatLit)))
	 (if ls/false
	     (apply (lambda Vars
		      (clause-body Cata Cdecls ThreadedIds
				   (extend-backquote Template B0 B ...)))
		    ls/false)
	     (match-help Template Cata Obj ThreadedIds Rest ...))))))

  (define-syntax clause-body
    (lambda (x)
      (define build-mapper
	(lambda (vars depth cata tIds)
	  (if (zero? depth)
	      cata
	      (with-syntax ((rest (build-mapper vars (- depth 1) cata tIds))
			    (vars vars)
			    (tIds tIds))
		#'(mapper rest vars tIds)))))
      (syntax-case x ()
	((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B)
	 (with-syntax (((Mapper ...)
			(map (lambda (mycata formals depth)
			       (build-mapper formals
					     (syntax-object->datum depth)
					     (syntax-case mycata ()
					       [#f #'Cata]
					       [exp #'exp])
					     #'(ThreadedId ...)))
			     (syntax->list #'(CMyCata ...))
			     (syntax->list #'((CFormal ...) ...))
			     (syntax->list #'(CDepth ...))))
		       (((ThreadedId ...) ...)
			(map (lambda (x) #'(ThreadedId ...))
			     (syntax->list #'((CFormal ...) ...)))))
	   #'(let-values** (([ThreadedId ... CFormal ...]
			     (Mapper ThreadedId ... CVar))
			    ...)
			   B))))))

  (define-syntax guard-body
    (lambda (x)
      (syntax-case x ()
	((_ ((Cvar Cdepth MyCata Cformal ...) ...) B)
	 (with-syntax (((CF ...) (apply append (map syntax->list (syntax->list #'((Cformal ...) ...))))))
	   #'(let-syntax
		 ((CF
		   (lambda (x)
		     (syntax-case x ()
		       (Name
                        (syntax-error #'Name
				      "guard cannot refer to return-value variable")))))
		  ...)
	       B))))))

  (define-syntax convert-pat
    ;; returns sexp-pat x vars x cdecls
    (let ()
      (define ellipsis?
	(lambda (x)
	  (and (identifier? x) (eq? (syntax-e x) '...))))
      (define Var?
	(lambda (x)
	  (syntax-case x (->)
	    [-> #f]
	    [id (identifier? #'id)])))
      (define (f syn vars cdecls depth)
	(syntax-case syn (unquote)
	  ((unquote . stuff) ; separate for better error detection
	   (syntax-case syn (unquote ->)
	     ((unquote [MyCata -> Var ...])
	      (andmap Var? (syntax->list #'(Var ...)))
	      (with-syntax (((Temp) (generate-temporaries '(x)))
			    (Depth depth))
		(values #'any
			(cons #'Temp vars)
			(cons #'[Temp Depth MyCata Var ...] cdecls))))
	     ((unquote [Var ...])
	      (andmap Var? (syntax->list #'(Var ...)))
	      (with-syntax (((Temp) (generate-temporaries '(x)))
			    (Depth depth))
		(values #'any
			(cons #'Temp vars)
			(cons #'[Temp Depth #f Var ...] cdecls))))
	     ((unquote Var)
	      (Var? #'Var)
	      (values #'any (cons #'Var vars) cdecls))))
	  (((unquote . stuff) Dots) ; separate for better error detection
	   (ellipsis? #'Dots)
	   (syntax-case syn (unquote ->)
	     (((unquote [MyCata -> Var ...]) Dots)
	      (andmap Var? (syntax->list #'(Var ...)))
	      (with-syntax (((Temp) (generate-temporaries '(x)))
			    (Depth+1 (add1 depth)))
		(values #'each-any
			(cons #'Temp vars)
			(cons #'[Temp Depth+1 MyCata Var ...] cdecls))))
	     (((unquote [Var ...]) Dots)
	      (andmap Var? (syntax->list #'(Var ...)))
	      (with-syntax (((Temp) (generate-temporaries '(x)))
			    (Depth+1 (add1 depth)))
		(values #'each-any
			(cons #'Temp vars)
			(cons #'[Temp Depth+1 #f Var ...] cdecls))))
	     (((unquote Var) Dots)
	      (Var? #'Var)
	      (values #'each-any (cons #'Var vars) cdecls))
	     ((expr Dots) (syntax-error #'expr "match-pattern unquote syntax"))))
	  ((Pat Dots)
	   (ellipsis? #'Dots)
	   (let-synvalues* (((Dpat Dvars Dcdecls)
			     (f #'Pat vars cdecls (add1 depth))))
;                           (printf "GOT VARS: ~s\n" vars)
			   (with-syntax ((Size (- (length (syntax->list #'Dvars))
						  ;; RRN: this is screwy:
						  (length 
						   (if (syntax? vars)
						       (syntax->list vars)
						       vars))
						  )))
			     ;;MCJ wrapped syntax->list around vars 
			     (values #'#(each Dpat Size) #'Dvars #'Dcdecls))))
	  ((Pat Dots . Rest)
	   (ellipsis? #'Dots)
	   (let-synvalues* (((Rpat Rvars Rcdecls)
			     (f #'Rest vars cdecls depth))
			    ((Dpat Dvars Dcdecls)
			     (f #'(Pat (... ...)) #'Rvars #'Rcdecls
				depth)))
			   (with-syntax ((Size (- (length (syntax->list #'Dvars)) (length (syntax->list #'Rvars))))
					 ((RevRestTl . RevRest) (reverseX (syntax->list #'Rpat) '())))
			     (values #'#(tail-each Dpat Size RevRest RevRestTl)
				     #'Dvars #'Dcdecls))))
	  ((X . Y)
	   (let-synvalues* (((Ypat Yvars Ycdecls)
			     (f #'Y vars cdecls depth))
			    ((Xpat Xvars Xcdecls)
			     (f #'X #'Yvars #'Ycdecls depth)))
			   (values #'(Xpat . Ypat) #'Xvars #'Xcdecls)))
	  (() (values #'() vars cdecls))
	  (#(X ...)
	   (let-synvalues* (((Pat Vars CDecls) (f #'(X ...) vars cdecls depth)))
			   (values #'#(vector Pat) #'Vars #'CDecls)))
	  (Thing (values #'#(atom Thing) vars cdecls))))
      (define reverseX
	(lambda (ls acc)
	  (if (pair? ls)
	      (reverseX (cdr ls) (cons (car ls) acc))
	      (cons ls acc))))
      (lambda (syn) 
	(syntax-case syn ()
	  ((_ syn (kh . kt))
	   (let-synvalues* (((a b c) (f #'syn '() '() 0)))
			   #'(kh 'a b c . kt)))))))

  (define-syntax mapper
    (lambda (x)
      (syntax-case x ()
	((_ F (RetId ...) (ThreadId ...))
	 (with-syntax (((t ...) (generate-temporaries #'(RetId ...)))
		       ((ts ...) (generate-temporaries #'(RetId ...)))
		       ((null ...) (map (lambda (x) #'()) (syntax->list #'(RetId ...)))))
	   #'(let ((fun F))
	       (rec g
		    (lambda (ThreadId ... ls)
		      (if (null? ls)
			  (values ThreadId ... null ...)
			  (call-with-values
			      (lambda () (g ThreadId ... (cdr ls)))
			    (lambda (ThreadId ... ts ...)
			      (call-with-values
				  (lambda () (fun ThreadId ... (car ls)))
				(lambda (ThreadId ... t ...)
				  (values ThreadId ... (cons t ts) ...))))))))))))))

;;; ------------------------------

  (define-syntax my-backquote
    (lambda (x)
      (define ellipsis?
	(lambda (x)
	  (and (identifier? x) (eq? (syntax-e x) '...))))
      (define destruct
	(lambda (Orig x depth)
	  (syntax-case x (quasiquote unquote unquote-splicing)
	    ;; inner quasiquote
	    ((quasiquote Exp)
	     (with-values (destruct Orig #'Exp (add1 depth))
	       (syntax-lambda (Builder Vars Exps)
			      (if (null? #'Vars)
				  (values #''(quasiquote Exp) '() '())
				  (values #'(list 'quasiquote Builder) #'Vars #'Exps)))))
	    ;; unquote
	    ((unquote Exp)
	     (zero? depth)
	     (with-temp X
			(values #'X (list #'X) (list #'Exp))))
	    ((unquote Exp)
	     (with-values (destruct Orig #'Exp (sub1 depth))
	       (syntax-lambda (Builder Vars Exps)
			      (if (null? #'Vars)
				  (values #''(unquote Exp) '() '())
				  (values #'(list 'unquote Builder) #'Vars #'Exps)))))
	    ;; splicing
	    (((unquote-splicing Exp))
	     (zero? depth)
	     (with-temp X
			(values #'X (list #'X) (list #'Exp))))
	    (((unquote-splicing Exp ...))
	     (zero? depth)
	     (with-temps (X ...) (Exp ...)
			 (values #'(append X ...) #'(X ...) #'(Exp ...))))
	    (((unquote-splicing Exp ...) . Rest)
	     (zero? depth)
	     (with-values (destruct Orig #'Rest depth)
	       (syntax-lambda (Builder Vars Exps)
			      (with-temps (X ...) (Exp ...)
					  (if (null? #'Vars)
					      (values #'(append X ... 'Rest)
						      #'(X ...) #'(Exp ...))
					      (values #'(append X ... Builder)
						      #'(X ... . Vars) #'(Exp ... . Exps)))))))
	    ((unquote-splicing Exp ...)
	     (with-values (destruct Orig #'(Exp ...) (sub1 depth))
	       (syntax-lambda (Builder Vars Exps)
			      (if (null? #'Vars)
				  (values #''(unquote-splicing Exp ...) '() '())
				  (values #'(cons 'unquote-splicing Builder)
					  #'Vars #'Exps)))))
	    ;; dots
	    (((unquote Exp) Dots)
	     (and (zero? depth) (ellipsis? #'Dots))
	     (with-temp X
			(values #'X (list #'X) (list #'Exp))))
	    (((unquote Exp) Dots . Rest)
	     (and (zero? depth) (ellipsis? #'Dots))
	     (with-values (destruct Orig #'Rest depth)
	       (syntax-lambda (RestBuilder RestVars RestExps)
			      (with-syntax ((TailExp
					     (if (stx-null? #'RestVars)
						 #''Rest
						 #'RestBuilder)))
				(with-temp X
					   (values #'(append X TailExp)
						   (cons #'X #'RestVars)
						   (cons #'Exp #'RestExps)))))))
	    ((Exp Dots . Rest)
	     (and (zero? depth) (ellipsis? #'Dots))
	     (with-values (destruct Orig #'Exp depth)
	       (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
			      (if (null? #'(ExpVar ...))
				  (syntax-error Orig "Bad ellipsis")
				  (with-values (destruct Orig #'Rest depth)
				    (syntax-lambda (RestBuilder RestVars RestExps)
						   (with-syntax ((TailExp
								  (if (null? #'RestVars)
								      #''Rest
								      #'RestBuilder))
								 (Orig Orig))
						     (values #'(let f ((ExpVar ExpVar) ...)
								 (if (and (pair? ExpVar) ...)
								     (cons
								      (let ((ExpVar (car ExpVar)) ...)
									ExpBuilder)
								      (f (cdr ExpVar) ...))
								     (if (and (null? ExpVar) ...)
									 TailExp
									 (error 'unquote
										"Mismatched lists in ~s"
										Orig))))
							     (append (syntax->list #'(ExpVar ...)) (syntax->list #'RestVars))
							     (append (syntax->list #'(ExpExp ...)) (syntax->list #'RestExps))))))))))
	    ;; Vectors
	    (#(X ...)
	     (with-values (destruct Orig #'(X ...) depth)
	       (syntax-lambda (LsBuilder LsVars LsExps)
			      (values #'(list->vector LsBuilder) #'LsVars #'LsExps))))
	    ;; random stuff
	    ((Hd . Tl)
	     (with-values (destruct Orig #'Hd depth)
	       (syntax-lambda (HdBuilder HdVars HdExps)
			      (with-values (destruct Orig #'Tl depth)
				(syntax-lambda (TlBuilder TlVars TlExps)
					       (with-syntax ((Hd (if (null? #'HdVars)
								     #''Hd
								     #'HdBuilder))
							     (Tl (if (null? #'TlVars)
								     #''Tl
								     #'TlBuilder)))
						 (values #'(cons Hd Tl)
							 (append (syntax->list #'HdVars) (syntax->list #'TlVars))
							 (append (syntax->list #'HdExps) (syntax->list #'TlExps)))))))))
	    (OtherThing
	     (values #''OtherThing '() '())))))
      ;; macro begins
      (syntax-case x ()
	((_ Datum)
	 (with-values (destruct #'(quasiquote Datum) #'Datum 0)
	   (syntax-lambda (Builder (Var ...) (Exp ...))
			  (if (null? #'(Var ...))
			      #''Datum
			      #'(let ((Var Exp) ...)
				  Builder))))))))

  (define-syntax extend-backquote
    (lambda (x)
      (syntax-case x ()
	((_ Template Exp ...)
	 (with-syntax ((quasiquote
			(datum->syntax-object #'Template 'quasiquote)))
	   #'(let-syntax ((quasiquote
			   (lambda (x)
			     (syntax-case x ()
			       ((_ Foo) #'(my-backquote Foo))))))
	       Exp ...))))))

;;; ------------------------------

  (define-syntax with-values
    (syntax-rules ()
      ((_ P C) (call-with-values (lambda () P) C))))

  (define-syntax letcc
    (syntax-rules ()
      ((_ V B0 B ...) (call/ec (lambda (V) B0 B ...)))))

  (define classify-list
    (lambda (ls)
      (cond
       ((null? ls) 'proper)
       ((not (pair? ls)) 'improper)
       (else
        (let f ((tortoise ls) (hare (cdr ls)))
          (cond
	   ((eq? tortoise hare) 'infinite)
	   ((null? hare) 'proper)
	   ((not (pair? hare)) 'improper)
	   (else
	    (let ((hare (cdr hare)))
	      (cond
	       ((null? hare) 'proper)
	       ((not (pair? hare)) 'improper)
	       (else (f (cdr ls) (cdr hare))))))))))))

  (define ilist-copy-flat
    (lambda (ils)
      (let f ((tortoise ils) (hare (cdr ils)))
	(if (eq? tortoise hare)
	    (list (car tortoise))
	    (cons (car tortoise) (f (cdr tortoise) (cddr hare)))))))

  (define sexp-dispatch
    (lambda (obj pat);; #f or list of vars
      (letcc escape
	     (let ((fail (lambda () (escape #f))))
	       (let f ((pat pat) (obj obj) (vals '()))
		 (cond
		  ((eq? pat 'any)
		   (cons obj vals))
		  ((eq? pat 'each-any)
		   ;; handle infinities
		   (case (classify-list obj)
		     ((proper infinite) (cons obj vals))
		     ((improper) (fail))))
		  ((pair? pat)
		   (if (pair? obj)
		       (f (car pat) (car obj) (f (cdr pat) (cdr obj) vals))
		       (fail)))
		  ((vector? pat)
		   (case (vector-ref pat 0)
		     ((atom)
		      (let ((a (vector-ref pat 1)))
			(if (eqv? obj a)
			    vals
			    (fail))))
		     ((vector)
		      (if (vector? obj)
			  (let ((vec-pat (vector-ref pat 1)))
			    (f vec-pat (vector->list obj) vals))
			  (fail)))
		     ((each)
		      ;; if infinite, copy the list as flat, then do the matching,
		      ;; then do some set-cdrs. 
		      (let ((each-pat (vector-ref pat 1))
			    (each-size (vector-ref pat 2)))
			(case (classify-list obj)
			  ((improper) (fail))
			  ((infinite)
			   (error 'iu-match "not handling infinite lists at the moment...")
			   #;
			   (let ((each-vals (f pat (ilist-copy-flat obj) '())))
			     (for-each (lambda (x) (set-cdr! (last-pair x) x))
				       each-vals)
			     (append each-vals vals)))
			  ((proper)
			   (append
			    (let g ((obj obj))
			      (if (null? obj)
				  (make-list each-size '())
				  (let ((hd-vals (f each-pat (car obj) '()))
					(tl-vals (g (cdr obj))))
				    (map cons hd-vals tl-vals))))
			    vals)))))
		     ((tail-each)
		      (let ((each-pat (vector-ref pat 1))
			    (each-size (vector-ref pat 2))
			    (revtail-pat (vector-ref pat 3))
			    (revtail-tail-pat (vector-ref pat 4)))
			(when (eq? (classify-list obj) 'infinite) (fail))
			(with-values
			    (let g ((obj obj))
			      ;; in-tail?, vals, revtail-left/ls
			      (cond
			       ((pair? obj)
				(with-values (g (cdr obj))
				  (lambda (in-tail? vals tail-left/ls)
				    (if in-tail?
					(if (null? tail-left/ls)
					    (values #f vals (list (car obj)))
					    (values #t (f (car tail-left/ls)
							  (car obj)
							  vals)
						    (cdr tail-left/ls)))
					(values #f vals
						(cons (car obj) tail-left/ls))))))
			       (else
				(values #t
					(f revtail-tail-pat obj '())
					revtail-pat))))
			  (lambda (in-tail? vals tail-left/ls)
			    (if in-tail?
				(if (null? tail-left/ls)
				    (append (make-list each-size '())
					    vals)
				    (fail))
				(f each-pat tail-left/ls vals))))))))
		  (else
		   (if (eqv? obj pat)
		       vals
		       (fail)))))))))
  )



;;;CHANGELOG

;; [04 Nov 2005]
;; rrn fixed a bug in the code for handling ellipses.  
;; (was (length (syntax->list vars)) rather than (length vars))

;; [13 March 2002]
;; rkd added following change by Friedman and Ganz to the main source
;; code thread and fixed a couple of minor problems.

;; [9 March 2002]
;; Dan Friedman and Steve Ganz added the ability to use identical pattern
;; variables.  The patterns represented by the variables are compared
;; using the value of the parameter match-equality-test, which defaults
;; to equal?.
;;
;; > (match '(1 2 1 2 1)
;;     [(,a ,b ,a ,b ,a) (guard (number? a) (number? b)) (+ a b)])
;; 3
;; ;;
;; > (match '((1 2 3) 5 (1 2 3))
;;     [((,a ...) ,b (,a ...)) `(,a ... ,b)])
;; (1 2 3 5)
;; ;;
;; > (parameterize ([match-equality-test (lambda (x y) (equal? x (reverse y)))])
;;     (match '((1 2 3) (3 2 1))   
;;       [(,a ,a) 'yes]
;;       [,oops 'no]))
;; yes

;; [10 Jan 2002]
;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to
;; blow up.  The bug was caused by a bug in the sexp-dispatch procedure
;; where a base value empty list was passed to an accumulator from inside
;; the recursion, instead of passing the old value of the accumulator.

;; [14 Jan 2001]
;; rkd added syntax checks to unquote pattern parsing to weed out invalid
;; patterns like ,#(a) and ,[(vector-ref d 1)].

;; [14 Jan 2001]
;; rkd added ,[Cata -> Id* ...] to allow specification of recursion
;; function.  ,[Id* ...] recurs to match; ,[Cata -> Id* ...] recurs
;; to Cata.

;; [14 Jan 2001]
;; rkd tightened up checks for ellipses and nested quasiquote; was comparing
;; symbolic names, which, as had been noted in the source, is a possible
;; hygiene bug.  Replaced error call in guard-body with syntax-error to
;; allow error to include source line/character information.

;; [13 Jan 2001]
;; rkd fixed match patterns of the form (stuff* ,[x] ... stuff+), which
;; had been recurring on subforms of each item rather than on the items
;; themselves.

;; [29 Feb 2000]
;; Fixed a case sensitivity bug.

;; [24 Feb 2000]
;; Matcher now handles vector patterns.  Quasiquote also handles
;; vector patterns, but does NOT do the csv6.2 optimization of
;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y).
;; Also fixed bug in (P ... . P) matching code. 

;; [23 Feb 2000]
;; KSM fixed bug in unquote-splicing inside quasiquote.

;; [10 Feb 2000]
;; New forms match+ and trace-match+ thread arguments right-to-left.
;; The pattern (P ... . P) now works the way you might expect.
;; Infinite lists are now properly matched (and not matched).
;; Removed the @ pattern.
;; Internal: No longer converting into syntax-case. 

;; [6 Feb 2000]
;; Added expansion-time error message for referring to cata variable
;; in a guard.

;; [4 Feb 2000]
;; Fixed backquote so it can handle nested backquote (oops).
;; Double-backquoted elipses are neutralized just as double-backquoted
;; unquotes are.  So:
;;   `(a ,'(1 2 3) ... b)    =eval=> (a 1 2 3 b)
;;   ``(a ,'(1 2 3) ... b)   =eval=> `(a ,'(1 2 3) ... b)
;;   ``(a ,(,(1 2 3) ...) b) =eval=> `(a ,(1 2 3) b)
;; Added support for
;;   `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b))

;; [1 Feb 2000]
;; Fixed a bug involving forgetting to quote stuff in the revised backquote.
;; Recognized unquote-splicing and signalled errors in the appropriate places.
;; Added support for deep elipses in backquote.
;; Rewrote backquote so it does the rebuilding directly instead of
;; expanding into Chez's backquote. 

;; [31 Jan 2000]
;; Kent Dybvig fixed template bug.

;; [31 Jan 2000]
;; Added the trace-match form, and made guards contain
;; an explicit and expression:
;;    (guard E ...) ==> (guard (and E ...))

;; [26 Jan 2000]
;; Inside the clauses of match expressions, the following
;; transformation is performed inside backquote expressions:
;;    ,v ...      ==> ,@v
;;    (,v ,w) ... ==> ,@(map list v w)
;;    etc.

;(require iu-match)

;; RRN: DEBUGGING
;(define (f)
;  (match '((1 2) (3 4))
;    [((,x ,y) ...) y]))
;(f)