fmatch

fmatch

[stefan]

Hi,

I've been experimenting lately with an inline match construct, very much like 
using compiled regexps. That is I created a tiny VM that was targeted to 
do matching. to show it consider

guile> (def f ((x y 'a 'b) (+ x y)))

then

guile> ,x f
  0    (assert-nargs-ee 0 1)
   3    (reserve-locals 0 4)
   6    (object-ref 1)                  ;; #(1 9 0 1 2 3 4 1 2 2 4 1 3 a 4 1 3 
b 4 3 () 0)
   8    (fast-match)
   9    (br-if-not :L195)               ;; -> 19
  13    (local-ref 3)                   ;; `x'
  15    (local-ref 2)                   ;; `y'
  17    (add)                                  at standard input:1:20
  18    (return)
  19    (toplevel-ref 2)                ;; `error'
  21    (object-ref 3)                  ;; "no match in f"
  23    (tail-call 1)

large patterns yield a speedup of 15 times acording to my tests compared 
with (ice-9 match).

I used guile-1.9.10. Does this release have a lot of checks compiled in so 
that the comparison is unfair?

Anyway, I will try to tweak the code even further somthing along

(object-ref 1)
(fast-match)
(br L1)
(br L2)
(br L3)
....
(br Ln)

Here the fast-match routine can FETCH the br commands and issue them directly
and hence one can have one compiled pattern in stead of one for each row in 
the matcher. 

/Stefan

	    

Re: fmatch

[Ludovic Courtès]

Hi Stefan,

stefan <stefan.tampe@spray.se> writes:

> I've been experimenting lately with an inline match construct, very much like 
> using compiled regexps.

Sounds interesting.

> That is I created a tiny VM that was targeted to do matching. to show
> it consider
>
> guile> (def f ((x y 'a 'b) (+ x y)))

(Such a ‘def’ construct would be less convenient than ‘match’ IMO.)

> large patterns yield a speedup of 15 times acording to my tests compared 
> with (ice-9 match).
>
> I used guile-1.9.10. Does this release have a lot of checks compiled in so 
> that the comparison is unfair?

All list/pair accessors type-check their arguments (this has always been
the case with Guile so that Scheme code cannot yield to segfaults and
the like.)

> Anyway, I will try to tweak the code even further somthing along
>
> (object-ref 1)
> (fast-match)
> (br L1)
> (br L2)
> (br L3)
> ....
> (br Ln)
>
> Here the fast-match routine can FETCH the br commands and issue them directly
> and hence one can have one compiled pattern in stead of one for each row in 
> the matcher. 

I don’t quite understand how it differs from what happens without a
‘fast-match’ instruction.  Can you show the code for ‘fast-match’?

Thanks,
Ludo’.

Re: fmatch

[stefan]

On Friday 07 May 2010 01:59:13 pm Ludovic Courtès wrote:
> Hi Stefan,
> 
> stefan <stefan.tampe@spray.se> writes:
> > I've been experimenting lately with an inline match construct, very much
> > like using compiled regexps.
> 
> Sounds interesting.
> 
> > That is I created a tiny VM that was targeted to do matching. to show
> > it consider
> >
> > guile> (def f ((x y 'a 'b) (+ x y)))
 
> (Such a ‘def’ construct would be less convenient than ‘match’ IMO.)

You have the full match, match-lambda etc of cause if you need it. I just
use a litle syntactic sugar.

> > large patterns yield a speedup of 15 times acording to my tests compared
> > with (ice-9 match).
> >
> > I used guile-1.9.10. Does this release have a lot of checks compiled in
> > so that the comparison is unfair?
> 
> All list/pair accessors type-check their arguments (this has always been
> the case with Guile so that Scheme code cannot yield to segfaults and
> the like.)

usually the generated match code is somehting like
(if (pair? x)
    (if (equal? x data)
        (let a34 (cdr x) ...)
	(goto-next))
    (goto-next))

And the checks are already there. So for this isolated system in should
be fine to skip the check. But I don't think it explains the speed 
difference.
	
	    

> > Anyway, I will try to tweak the code even further somthing along
> >
> > (object-ref 1)
> > (fast-match)
> > (br L1)
> > (br L2)
> > (br L3)
> > ....
> > (br Ln)
> >
> > Here the fast-match routine can FETCH the br commands and issue them
> > directly and hence one can have one compiled pattern in stead of one for
> > each row in the matcher.
> 
> I don’t quite understand how it differs from what happens without a
> ‘fast-match’ instruction.  Can you show the code for ‘fast-match’?

The core of the matcher is a loop with a set of if's arranged so that in the 
mean it will do 2-3 checks and then find the instruction, so no named labels.

the core of the code look like,
  #define M_CONTINUE {pat ++; continue;}
  while(1)
    {    
      //printf("match-instruction (*)> %d\n",((int) Ix) >> 2);fflush(stdout);
      if(SCM_UNLIKELY(Ix == i_cons))
	{
	  if(SCM_CONSP(x))
	    {
	      PUSH(SCM_CDR(x));
	      x = SCM_CAR(x);
	      M_CONTINUE;
	    }
	  goto return_false;
	}
	  
      if(SCM_UNLIKELY(Ix == i_eq))
	{
	  pat ++;
	  if(*pat == x) M_CONTINUE;
	  goto return_false;
	}
	  
      if(SCM_UNLIKELY(Ix == i_var))
	{
	  pat ++;
	  LOCAL_SET((SCM_UNPACK(*pat) >> 2) , x);
	  M_CONTINUE;
	}
      
      if(SCM_UNLIKELY(Ix == i_pop))
	{
	  POP(x);
	  M_CONTINUE;
	}

	...
	
And we see the most used instructions are int the top 4 checks. I don't know 
how efficient gcc is to compile the named label method used in the guile vm. 
But this while loop is not exotic so that one should expect good assembler 
from 
gcc. Also an SCM array is used which might explain some speedup. The match 
construct itself generats a more wordier vm instruction list as well due to 
the general nature of guile vm.

To see the compilation
((a b) a)

translates to
<cons> <var> a.id <pop> <cons> <var> b.id <pop> <eq> '() <end>

8 instructions!!

(if (pair? x1)
    (let ((a  (car x1))
	  (x2 (cdr x1)))
      (if (pair? x2)
	  (let ((b (car x2)))
	    (if (null? x2)
		...

a 15-16 instructions, but some inneficiency in the match algoritm maby
means a factor of 3 between them, also it is brancy which seams to cost
extra cycles.

but 15x difference?

anyway, I'm experimenting to do a directly dispatch to the correct code
with 

if(SCM_LIKELY(Ix == i_end)) // <end> jmp-addr
  {
  gp_end:
    //printf("(sp: %d   ==  sp_save: %d\n",sp,sp_save);fflush(stdout);
    int ijump = (*(pat+1)) >> 2;
    if(SCM_UNLIKELY(ijump == 0))
      {	      
	scm_t_int32 offset;
	//ip: <obj> compiled.id <br> a1 b1 c1 <br> a2 b2 c2 ...
	//                      | row = 0    | row = 1    | ...
	ip += 3 + row * 4; 
	FETCH_OFFSET (offset);
	ip += offset;
	//Store the offset for a fast lookup of the adress!!, 
	*(pat+1) = SCM_PACK(((scm_t_bits) ((offset + 3 * row * 4) << 2)) + 2); 
	if (offset < 0)
	  VM_HANDLE_INTERRUPTS;
      }
    else
      ip += (*(pat + 1)) >> 2;
    NEXT;
  }

Modeilling the function data with br and obect-ref will make it possible
quickly test out this idea. A in a finished solution you need to make it less
hacky in it's nature.


I also have similar code for usage in prolog like matching e.g. unfication +
 backtracking I would expect at least the same speedup here. Note that for 
this application a pure unwinding of the logic, similar to the match macro 
will yield very bloated code and going for a targeted virtual machine will 
make 
for lean and efficient code.

I hope that in the end a prolog implementation using this approach would be 
3-4
times slower that what you have with a more targeted platform like gnu prolog.

So in a sense this is a test of what you want. Compare the speed difference of 
using c-based or scheme based solution. Still I expect the macth construct to 
be easier to hack and improve uppon and at some point a direct match version 
will win because you can compile it naitively.

Hope the fogg clears a little
Cheers

Stefan

Re: fmatch

[Ludovic Courtès]

Hello!

stefan <stefan.tampe@spray.se> writes:

>> > large patterns yield a speedup of 15 times acording to my tests compared
>> > with (ice-9 match).
>> >
>> > I used guile-1.9.10. Does this release have a lot of checks compiled in
>> > so that the comparison is unfair?
>> 
>> All list/pair accessors type-check their arguments (this has always been
>> the case with Guile so that Scheme code cannot yield to segfaults and
>> the like.)
>
> usually the generated match code is somehting like
> (if (pair? x)
>     (if (equal? x data)
>         (let a34 (cdr x) ...)
> 	(goto-next))
>     (goto-next))
>
> And the checks are already there. So for this isolated system in should
> be fine to skip the check. But I don't think it explains the speed 
> difference.

Agreed.

> The core of the matcher is a loop with a set of if's arranged so that in the 
> mean it will do 2-3 checks and then find the instruction, so no named labels.

You mean no “labels as values” (info "(gcc) Labels as Values"), right?

> the core of the code look like,
>   #define M_CONTINUE {pat ++; continue;}
>   while(1)
>     {    
>       //printf("match-instruction (*)> %d\n",((int) Ix) >> 2);fflush(stdout);
>       if(SCM_UNLIKELY(Ix == i_cons))
> 	{
> 	  if(SCM_CONSP(x))
> 	    {
> 	      PUSH(SCM_CDR(x));
> 	      x = SCM_CAR(x);
> 	      M_CONTINUE;
> 	    }
> 	  goto return_false;
> 	}

Hmmmm.  My first reaction is that I’d rather avoid complex VM
instructions like this and instead focus on native compilation (AOT or
JIT) when we feel like improving performance.

What do you think?

[...]

> I also have similar code for usage in prolog like matching e.g. unfication +
>  backtracking I would expect at least the same speedup here. Note that for 
> this application a pure unwinding of the logic, similar to the match macro 
> will yield very bloated code and going for a targeted virtual machine will 
> make 
> for lean and efficient code.
>
> I hope that in the end a prolog implementation using this approach would be 
> 3-4
> times slower that what you have with a more targeted platform like gnu prolog.

This all sounds like exciting work!

> So in a sense this is a test of what you want. Compare the speed difference of 
> using c-based or scheme based solution. Still I expect the macth construct to 
> be easier to hack and improve uppon and at some point a direct match version 
> will win because you can compile it naitively.

Well, until 1.8, the focus in Guile had been to write the “hot spots” in
C, for performance.  However, that doesn’t scale well and leads to a
hard to maintain code base (we want to write Scheme in the first place,
not C).

For 2.2 and beyond, I really think the focus should be on allowing hot
spots to be written in Scheme, which means compiling Scheme code
natively.  This would be beneficial to all Scheme code, not just this
specific pattern matching construct.

Thanks,
Ludo’.

Re: fmatch

[stefan]

> > The core of the matcher is a loop with a set of if's arranged so that in
> > the mean it will do 2-3 checks and then find the instruction, so no named
> > labels.
> 
> You mean no “labels as values” (info "(gcc) Labels as Values"), right?

Yep!
 
> Hmmmm.  My first reaction is that I’d rather avoid complex VM
> instructions like this and instead focus on native compilation (AOT or
> JIT) when we feel like improving performance.
> 
> What do you think?

Well, I think that for plain pattern matching, a sane compilation is the way 
to go in the long run. For unification I'm not sure. Code generated from 
unwinding unification code typically increases geometrically with the number 
of words and I'm not sure this is needed. I think that it is hard to beat a 
tiny vm that does this well in c. In a way this is a clean solution. Think
of debugging the generated code for errors, you will need special hacks to 
the scheme in order to make this workable and there is a lot of similar 
overhead associated with bloated code. So my thinking is that for some time 
we will have a need for this tiny vm as one extra instruction, although a 
complex one. So why not use it for plain matching as well. At some point
we could write this tiny vm in Scheme :-). Implementing it all in scheme 
today would mean that I must work with a slow matcher which is not ideal

But to judge what to do. how far are we from a scheme compiler?

> [...]
> 
> > I also have similar code for usage in prolog like matching e.g.
> > unfication + backtracking I would expect at least the same speedup here.
> > Note that for this application a pure unwinding of the logic, similar to
> > the match macro will yield very bloated code and going for a targeted
> > virtual machine will make
> > for lean and efficient code.
> >
> > I hope that in the end a prolog implementation using this approach would
> > be 3-4
> > times slower that what you have with a more targeted platform like gnu
> > prolog.
> 
> This all sounds like exciting work!

I have a matcher right know for the einstin case and it takes 90ms compared to
16-20 for gnu prolog on my machine. (The same method is used) I think 
that if I can dispatch more cleanly I could reduce it even further.

the code for the member function currently looks like,

(def gp-member
     ( X (+ (X . L)) F     (if (F)
			       #t
			       (begin (gp-unwind *gp-fi*) (gp-next)) ))
     ( X (+ (Y . L)) F     (gp-member X L F)                )
     ( X (+ ())      F     #f                               ))

Here the + directive extension is used to indicate a uniying match.
 *gp-fi* is implicitly bounded to a frame so that we can undo any variable 
settings. I find it very nice to work with pattern matchers that can 
handle both ordinary pattern matching and unifying pattern matching so it is
quite usefull to bundle these two things together.


 
> > So in a sense this is a test of what you want. Compare the speed
> > difference of using c-based or scheme based solution. Still I expect the
> > macth construct to be easier to hack and improve uppon and at some point
> > a direct match version will win because you can compile it naitively.
> 
> Well, until 1.8, the focus in Guile had been to write the “hot spots” in
> C, for performance.  However, that doesn’t scale well and leads to a
> hard to maintain code base (we want to write Scheme in the first place,
> not C).

I Agree with this experience.

> For 2.2 and beyond, I really think the focus should be on allowing hot
> spots to be written in Scheme, which means compiling Scheme code
> natively.  This would be beneficial to all Scheme code, not just this
> specific pattern matching construct.

This is clearly a good move. Hmm Ok, I see your point here. I could write 
the whole stuff out in scheme directly. Hmm it would still be nice to have
an implemenation in C and compare with what you get when introducing this 
code. Also one should focus on stuff in the right order. So if I spend the 
next 
two weeks writing a small prolog implementaion. Should we wait untill after 
2.2 to get the suggested speed and live with 15x performance hit? It is 
tempting to deliver that system and then spend the next years to shoot it 
down into pure scheme. 

Also I use this way of programming alot. It would be cool to have a fast 
implementaion at the desk within a short timeframe.

At least it is a fun hack!

/Stefan

Re: fmatch

[stefan]

On Sunday 09 May 2010 10:57:21 pm Ludovic Courtès wrote:
> Hi!
> 
> stefan <stefan.tampe@spray.se> writes:
> >> Hmmmm.  My first reaction is that I’d rather avoid complex VM
> >> instructions like this and instead focus on native compilation (AOT or
> >> JIT) when we feel like improving performance.
> >>
> >> What do you think?
> >
> > Well, I think that for plain pattern matching, a sane compilation is the
> > way to go in the long run. For unification I'm not sure.
> 
> OK.  I was just thinking about (ice-9 match).  Let’s start a separate
> thread for unification.  :-)

In a sense they are close actually But as you say let's push the unification
onto the stack!!

Actually (ice-9 match) has quit a lot of power and I would try keeping it a 
little thinner in the beginning for a speedier version.
 
> >> For 2.2 and beyond, I really think the focus should be on allowing hot
> >> spots to be written in Scheme, which means compiling Scheme code
> >> natively.  This would be beneficial to all Scheme code, not just this
> >> specific pattern matching construct.
> >
> > This is clearly a good move. Hmm Ok, I see your point here. I could write
> > the whole stuff out in scheme directly. Hmm it would still be nice to
> > have an implemenation in C and compare with what you get when introducing
> > this code. Also one should focus on stuff in the right order. So if I
> > spend the next
> > two weeks writing a small prolog implementaion. Should we wait untill
> > after 2.2 to get the suggested speed and live with 15x performance hit?
> > It is tempting to deliver that system and then spend the next years to
> > shoot it down into pure scheme.
> 
> Don’t hold your breath: native compilation won’t show up overnight.  ;-)

No problem. But then we might think about supporting some faster version.

> You /can/ implement hotspots in C, but you most likely don’t need to
> write special VM instructions for that.  Instead, you could probably
> implement primitive procedures in C (info "(guile) Primitive
> Procedures").

You then need to translate the action scheme code into a lambda and execute
that. That could work, I'll keep this as an option.

e.g.

(match x ((a b) (+ a b)))

(let ((F (lambda (a b) (+ a b))))
  (c-code-match x pat F))

This has it's elegance. So do you see any performancs 
issues using this?

/Stefan
		

Re: fmatch

[Ludovic Courtès]

Hi!

stefan <stefan.tampe@spray.se> writes:

>> Hmmmm.  My first reaction is that I’d rather avoid complex VM
>> instructions like this and instead focus on native compilation (AOT or
>> JIT) when we feel like improving performance.
>> 
>> What do you think?
>
> Well, I think that for plain pattern matching, a sane compilation is the way 
> to go in the long run. For unification I'm not sure.

OK.  I was just thinking about (ice-9 match).  Let’s start a separate
thread for unification.  :-)

>> For 2.2 and beyond, I really think the focus should be on allowing hot
>> spots to be written in Scheme, which means compiling Scheme code
>> natively.  This would be beneficial to all Scheme code, not just this
>> specific pattern matching construct.
>
> This is clearly a good move. Hmm Ok, I see your point here. I could write 
> the whole stuff out in scheme directly. Hmm it would still be nice to have
> an implemenation in C and compare with what you get when introducing this 
> code. Also one should focus on stuff in the right order. So if I spend the 
> next 
> two weeks writing a small prolog implementaion. Should we wait untill after 
> 2.2 to get the suggested speed and live with 15x performance hit? It is 
> tempting to deliver that system and then spend the next years to shoot it 
> down into pure scheme. 

Don’t hold your breath: native compilation won’t show up overnight.  ;-)

You /can/ implement hotspots in C, but you most likely don’t need to
write special VM instructions for that.  Instead, you could probably
implement primitive procedures in C (info "(guile) Primitive
Procedures").

Thanks,
Ludo’.

Re: fmatch

[Ludovic Courtès]

Hi,

stefan <stefan.tampe@spray.se> writes:

> (match x ((a b) (+ a b)))
>
> (let ((F (lambda (a b) (+ a b))))
>   (c-code-match x pat F))
>
> This has it's elegance. So do you see any performancs 
> issues using this?

I’d rather avoid C completely for (ice-9 match).  I was mentioning use
of C for the Prolog implementation you were discussing.

Thanks,
Ludo’.

Re: fmatch

[Stefan]

Ok,

I'm wiser. The pieces now fit together!

The big change in speed is mainly from the (ice-9 match) having an lambda
just as I described in a parent mail above. Just code it in hand scheme
or using the new match version of (ice-9 match) the difference seam to be on the size of 2x
rather then 15x. Now this speed difference is probably due to the lower instruction count.

This looks like it is enough to use the new match version or to gain a little in speed 
the guile vm itself.

/Stefan

Re: fmatch

[stefan]

Let me suggest.

Shall we say that we use the slightly modified version of (ice-9 match) that
ypu dug up for now!

I found that this code is much faster then the old code and then the 
speedup by using opcode is not much.


For unification we make a special matcher and keep it under a prolog 
library.

On a side note I have not gotten any answer from the author of that code 
that I modified.

Cheers
Stefan

On Monday 10 May 2010 10:26:53 am Ludovic Courtès wrote:
> Hi,
> 
> stefan <stefan.tampe@spray.se> writes:
> > (match x ((a b) (+ a b)))
> >
> > (let ((F (lambda (a b) (+ a b))))
> >   (c-code-match x pat F))
> >
> > This has it's elegance. So do you see any performancs
> > issues using this?
> 
> I’d rather avoid C completely for (ice-9 match).  I was mentioning use
> of C for the Prolog implementation you were discussing.
> 
> Thanks,
> Ludo’.
> 

Re: fmatch

[Ludovic Courtès]

Hi!

stefan <stefan.tampe@spray.se> writes:

> Shall we say that we use the slightly modified version of (ice-9 match) that
> ypu dug up for now!

Hmm, yes?  Please send an actual patch against Guile master, so we have
something concrete do discuss.  :-)

Can you make sure to isolate Guile-specific changes, ideally in a way
that allows us to include upstream files (match.scm itself and test
cases) unmodified?  See the sxml and lalr modules for examples.

> On a side note I have not gotten any answer from the author of that code 
> that I modified.

Hmm that’s unfortunate.

If we can’t get record-matching included upstream shortly, then I’d
suggest making the addition of record-matching a separate commit in our
repository, so we can easily find it in the future.

Could you do that?

Thanks!

Ludo’.

Re: fmatch

[stefan]

On Saturday 22 May 2010 11:03:12 pm Ludovic Courtès wrote:
> Hi!
> 
> stefan <stefan.tampe@spray.se> writes:
> > Shall we say that we use the slightly modified version of (ice-9 match)
> > that ypu dug up for now!
> 
> Hmm, yes?  Please send an actual patch against Guile master, so we have
> something concrete do discuss.  :-)

Yep,  I will do that.
 
> Can you make sure to isolate Guile-specific changes, ideally in a way
> that allows us to include upstream files (match.scm itself and test
> cases) unmodified?  See the sxml and lalr modules for examples.

will do.

> > On a side note I have not gotten any answer from the author of that code
> > that I modified.
> 
> Hmm that’s unfortunate.
Yes, maybe ask on irc? what channel?

> If we can’t get record-matching included upstream shortly, then I’d
> suggest making the addition of record-matching a separate commit in our
> repository, so we can easily find it in the future.

Separate commit?
 
> Could you do that?
> 
> Thanks!
> 
> Ludo’.
> 

Ludo, I'm relly a beginner in some respects so be patient :-)

Cheers!
Stefan

Re: fmatch

[stefan]

[-- Attachment #1: Type: Text/Plain, Size: 462 bytes --]

On Saturday 22 May 2010 11:03:12 pm Ludovic Courtès wrote:
> Hi!
> 
> stefan <stefan.tampe@spray.se> writes:
> > Shall we say that we use the slightly modified version of (ice-9 match)
> > that ypu dug up for now!
> 
> Hmm, yes?  Please send an actual patch against Guile master, so we have
> something concrete do discuss.  :-)

In this mail a patch is made for discussions. It's not upstream ready
but intended for further discussions.

/Stefan

[-- Attachment #2: match.patch --]
[-- Type: text/x-patch, Size: 86871 bytes --]

diff -crB guile-master-20100512/module/ice-9/match.scm guile-master-20100512_new//module/ice-9/match.scm
*** guile-master-20100512/module/ice-9/match.scm	2010-05-12 06:00:07.000000000 +0200
--- guile-master-20100512_new//module/ice-9/match.scm	2010-05-23 16:55:51.891684063 +0200
***************
*** 1,199 ****
! ;;; installed-scm-file
  
! ;;;; 	Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
! ;;;;
! ;;;; This library is free software; you can redistribute it and/or
! ;;;; modify it under the terms of the GNU Lesser General Public
! ;;;; License as published by the Free Software Foundation; either
! ;;;; version 3 of the License, or (at your option) any later version.
! ;;;; 
! ;;;; This library 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
! ;;;; Lesser General Public License for more details.
! ;;;; 
! ;;;; You should have received a copy of the GNU Lesser General Public
! ;;;; License along with this library; if not, write to the Free Software
! ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ;;;;
  
  (define-module (ice-9 match)
!   :use-module (ice-9 pretty-print)
!   :export (match match-lambda match-lambda* match-define
! 		 match-let match-let* match-letrec
! 		 define-structure define-const-structure
!                  match:andmap
! 		 match:error match:set-error
! 		 match:error-control match:set-error-control
! 		 match:structure-control match:set-structure-control
! 		 match:runtime-structures match:set-runtime-structures))
! 
! ;; The original code can be found at the Scheme Repository
! ;;
! ;;   http://www.cs.indiana.edu/scheme-repository/code.match.html
! ;;
! ;; or Andrew K. Wright's web page:
! ;;
! ;;   http://www.star-lab.com/wright/code.html
! 
! \f
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Pattern Matching Syntactic Extensions for Scheme
! ;;
! (define match:version "Version 1.19, Sep 15, 1995")
! ;;
! ;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
! ;; Adapted from code originally written by Bruce F. Duba, 1991.
! ;; This package also includes a modified version of Kent Dybvig's
! ;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
! ;; Prentice-Hall, NJ, 1987).
! ;;
! ;; This macro package extends Scheme with several new expression forms.
! ;; Following is a brief summary of the new forms.  See the associated
! ;; LaTeX documentation for a full description of their functionality.
! ;;
! ;;
! ;;         match expressions:
! ;;
! ;; exp ::= ...
! ;;       | (match exp clause ...)
! ;;       | (match-lambda clause ...)
! ;;       | (match-lambda* clause ...)
! ;;       | (match-let ((pat exp) ...) body)
! ;;       | (match-let* ((pat exp) ...) body)
! ;;       | (match-letrec ((pat exp) ...) body)
! ;;       | (match-define pat exp)
! ;;
! ;; clause ::= (pat body) | (pat => exp)
! ;;
! ;;         patterns:                       matches:
! ;;
! ;; pat ::= identifier                      anything, and binds identifier
! ;;       | _                               anything
! ;;       | ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | 'sexp                           an s-expression
! ;;       | 'symbol                         a symbol (special case of s-expr)
! ;;       | (pat_1 ... pat_n)               list of n elements
! ;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
! ;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #(pat_1 ... pat_n)              vector of n elements
! ;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #&pat                           box
! ;;       | ($ struct-name pat_1 ... pat_n) a structure
! ;;       | (= field pat)                   a field of a structure
! ;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
! ;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
! ;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
! ;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
! ;;                                           pat_1 thru pat_n match
! ;;       | (set! identifier)               anything, and binds setter
! ;;       | (get! identifier)               anything, and binds getter
! ;;       | `qp                             a quasi-pattern
! ;;
! ;; ooo ::= ...                             zero or more
! ;;       | ___                             zero or more
! ;;       | ..k                             k or more
! ;;       | __k                             k or more
! ;;
! ;;         quasi-patterns:                 matches:
! ;;
! ;; qp  ::= ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | identifier                      a symbol
! ;;       | (qp_1 ... qp_n)                 list of n elements
! ;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
! ;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #(qp_1 ... qp_n)                vector of n elements
! ;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #&qp                            box
! ;;       | ,pat                            a pattern
! ;;       | ,@pat                           a pattern
! ;;
! ;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
! ;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
! ;;
! ;;
! ;;         structure expressions:
! ;;
! ;; exp ::= ...
! ;;       | (define-structure (id_0 id_1 ... id_n))
! ;;       | (define-structure (id_0 id_1 ... id_n)
! ;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n)
! ;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
! ;;
! ;; arg ::= id | (! id) | (@ id)
! ;;
! ;;
! ;; match:error-control controls what code is generated for failed matches.
! ;; Possible values:
! ;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
! ;;  'fail - call match:error, or die at car or cdr
! ;;  'error - call match:error with the unmatched value
! ;;  'match - call match:error with the unmatched value _and_
! ;;             the quoted match expression
! ;; match:error-control is set by calling match:set-error-control with
! ;; the new value.
! ;;
! ;; match:error is called for a failed match.
! ;; match:error is set by calling match:set-error with the new value.
! ;;
! ;; match:structure-control controls the uniqueness of structures
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  'vector - (default) structures are vectors with a symbol in position 0
! ;;  'disjoint - structures are fully disjoint from all other values
! ;; match:structure-control is set by calling match:set-structure-control
! ;; with the new value.
! ;;
! ;; match:runtime-structures controls whether local structure declarations
! ;; generate new structures each time they are reached
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  #t - (default) each runtime occurrence generates a new structure
! ;;  #f - each lexical occurrence generates a new structure
! ;;
! ;; End of user visible/modifiable stuff.
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! (define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
! (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
! (define match:syntax-err (lambda (obj msg) (error msg obj)))
! (define match:disjoint-structure-tags (quote ()))
! (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
! (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
! (define match:structure-control (quote vector))
! (define match:set-structure-control (lambda (v) (set! match:structure-control v)))
! (define match:set-error (lambda (v) (set! match:error v)))
! (define match:error-control (quote error))
! (define match:set-error-control (lambda (v) (set! match:error-control v)))
! (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
! (define match:vector-structures (quote ()))
! (define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
! (defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
! (defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
! (defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
! (defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
! (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
! (defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
! (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
! (define match:runtime-structures #f)
! (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
! (define match:primitive-vector? vector?)
! (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
! (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
! (defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
--- 1,728 ----
! ;;
! 
! ;;;; match.scm -- portable hygienic pattern matcher
! ;;
! ;; This code is written by Alex Shinn and placed in the
! ;; Public Domain.  All warranties are disclaimed.
! 
! ;; This is a full superset of the popular MATCH package by Andrew
! ;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
! ;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
! 
! ;; This is a simple generative pattern matcher - each pattern is
! ;; expanded into the required tests, calling a failure continuation if
! ;; the tests fail.  This makes the logic easy to follow and extend,
! ;; but produces sub-optimal code in cases where you have many similar
! ;; clauses due to repeating the same tests.  Nonetheless a smart
! ;; compiler should be able to remove the redundant tests.  For
! ;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
! ;; hit.
  
! ;; The original version was written on 2006/11/29 and described in the
! ;; following Usenet post:
! ;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
! ;; and is still available at
! ;;   http://synthcode.com/scheme/match-simple.scm
! ;; It's just 80 lines for the core MATCH, and an extra 40 lines for
! ;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
! ;;
! ;; A variant of this file which uses COND-EXPAND in a few places for
! ;; performance can be found at
! ;;   http://synthcode.com/scheme/match-cond-expand.scm
! ;;
! ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
! ;; 2009/11/25 - adding `***' tree search patterns
! ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
! ;; 2008/03/15 - removing redundant check in vector patterns
! ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
! ;; 2007/09/04 - fixing quasiquote patterns
! ;; 2007/07/21 - allowing ellipse patterns in non-final list positions
! ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
! ;;              (thanks to Taylor Campbell)
! ;; 2007/04/08 - clean up, commenting
! ;; 2006/12/24 - bugfixes
! ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
  
  (define-module (ice-9 match)
!   #:use-module (srfi srfi-9)
!   #:export     (match-define match-let* match-let match-letrec match-lambda*
! 			     match-lambda match))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; force compile-time syntax errors with useful messages
! (define-syntax match-syntax-error
!   (syntax-rules ()
!     ((_) (match-syntax-error "invalid match-syntax-error usage"))))
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! ;; The basic interface.  MATCH just performs some basic syntax
! ;; validation, binds the match expression to a temporary variable `v',
! ;; and passes it on to MATCH-NEXT.  It's a constant throughout the
! ;; code below that the binding `v' is a direct variable reference, not
! ;; an expression.
! 
! (define-syntax match
!   (syntax-rules ()
!     ((match)
!      (match-syntax-error "missing match expression"))
!     ((match atom)
!      (match-syntax-error "no match clauses"))
!     ((match (app ...) (pat . body) ...)
!      (let ((v (app ...)))
!        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
!     ((match #(vec ...) (pat . body) ...)
!      (let ((v #(vec ...)))
!        (match-next v (v (set! v)) (pat . body) ...)))
!     ((match atom (pat . body) ...)
!      (let ((v atom))
!        (match-next v (atom (set! atom)) (pat . body) ...)))
!     ))
! 
! ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
! ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
! ;; clauses.  `g+s' is a list of two elements, the get! and set!
! ;; expressions respectively.
! 
! (define-syntax match-next
!   (syntax-rules (=>)
!     ;; no more clauses, the match failed
!     ((match-next v g+s)
!      (error 'match "no matching pattern"))
!     ;; named failure continuation
!     ((match-next v g+s (pat (=> failure) . body) . rest)
!      (let ((failure (lambda () (match-next v g+s . rest))))
!        ;; match-one analyzes the pattern for us
!        (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
!     ;; anonymous failure continuation, give it a dummy name
!     ((match-next v g+s (pat . body) . rest)
!      (match-next v g+s (pat (=> failure) . body) . rest))))
! 
! ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
! ;; MATCH-TWO.
! 
! (define-syntax match-one
!   (syntax-rules ()
!     ;; If it's a list of two or more values, check to see if the
!     ;; second one is an ellipse and handle accordingly, otherwise go
!     ;; to MATCH-TWO.
!     ((match-one v (p q . r) g+s sk fk i)
!      (match-check-ellipse
!       q
!       (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
!       (match-two v (p q . r) g+s sk fk i)))
!     ;; Go directly to MATCH-TWO.
!     ((match-one . x)
!      (match-two . x))))
! 
! ;; This is the guts of the pattern matcher.  We are passed a lot of
! ;; information in the form:
! ;;
! ;;   (match-two var pattern getter setter success-k fail-k (ids ...))
! ;;
! ;; usually abbreviated
! ;;
! ;;   (match-two v p g+s sk fk i)
! ;;
! ;; where VAR is the symbol name of the current variable we are
! ;; matching, PATTERN is the current pattern, getter and setter are the
! ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
! ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
! ;; continuation (which is just a thunk call and is thus safe to expand
! ;; multiple times) and IDS are the list of identifiers bound in the
! ;; pattern so far.
! 
! (define-syntax match-two
!   (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
!     ((match-two v () g+s (sk ...) fk i)
!      (if (null? v) (sk ... i) fk))
!     ((match-two v (quote p) g+s (sk ...) fk i)
!      (if (equal? v 'p) (sk ... i) fk))
!     ((match-two v (quasiquote p) . x)
!      (match-quasiquote v p . x))
!     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
!     ((match-two v (and p q ...) g+s sk fk i)
!      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
!     ((match-two v (or) g+s sk fk i) fk)
!     ((match-two v (or p) . x)
!      (match-one v p . x))
!     ((match-two v (or p ...) g+s sk fk i)
!      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
!     ((match-two v (not p) g+s (sk ...) fk i)
!      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
!     ((match-two v (get! getter) (g s) (sk ...) fk i)
!      (let ((getter (lambda () g))) (sk ... i)))
!     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
!      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
!     ((match-two v (? pred . p) g+s sk fk i)
!      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
!     
!     ;; stis, added $ support!
!     ((match-two v ($ n) g-s sk fk i)
!      (if (n v) sk fk))
!     
!     ((match-two v ($ nn p ...) g+s sk fk i)
!      (if (nn v)
! 	 (match-$ (and) 0 (p ...) v sk fk i)
! 	 fk))
!      
!     ;; stis, added the possibility to use set! and get to records    
!     ((match-two v (= 0 m p) g+s sk fk i)
!      (let ((w  (struct-ref v m)))
!        (match-one w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
! 
!     ((match-two v (= g s p) g+s sk fk i)
!      (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i)))
! 
!     ((match-two v (= proc p) g+s . x)
!      (let ((w (proc v))) '() (match-one w p . x)))
!     
!     ((match-two v (p ___ . r) g+s sk fk i)
!      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
!     ((match-two v (p) g+s sk fk i)
!      (if (and (pair? v) (null? (cdr v)))
!          (let ((w (car v)))
!            (match-one w p ((car v) (set-car! v)) sk fk i))
!          fk))
!     ((match-two v (p *** q) g+s sk fk i)
!      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
!     ((match-two v (p *** . q) g+s sk fk i)
!      (match-syntax-error "invalid use of ***" (p *** . q)))
!     ((match-two v (p . q) g+s sk fk i)
!      (if (pair? v)
!          (let ((w (car v)) (x (cdr v)))
!            (match-one w p ((car v) (set-car! v))
!                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
!                       fk
!                       i))
!          fk))
!     ((match-two v #(p ...) g+s . x)
!      (match-vector v 0 () (p ...) . x))
!     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
!     ;; Not a pair or vector or special literal, test to see if it's a
!     ;; new symbol, in which case we just bind it, or if it's an
!     ;; already bound symbol or some other literal, in which case we
!     ;; compare it with EQUAL?.
!     ((match-two v x g+s (sk ...) fk (id ...))
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (id ...)
!              ((new-sym? x sk2 fk2) sk2)
!              ((new-sym? y sk2 fk2) fk2))))
!        (new-sym? random-sym-to-match
!                  (let ((x v)) (sk ... (id ... x)))
!                  (if (equal? v x) (sk ... (id ...)) fk))))
!     ))
! 
! 
! (define-syntax match-$
!   (lambda (x)
!     (syntax-case x ()
!       ((q (a ...) m (p1 p2 ...) . v)
!        (with-syntax ((m+1 (datum->syntax (syntax q) 
! 					 (+ (syntax->datum (syntax m)) 1))))
! 	 (syntax (match-$ (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
!       ((_ newpat  m ()            v kt ke i)
!        (syntax (match-one v newpat () kt ke i))))))
! 
! 
!  
! ;; QUASIQUOTE patterns
! 
! (define-syntax match-quasiquote
!   (syntax-rules (unquote unquote-splicing quasiquote)
!     ((_ v (unquote p) g+s sk fk i)
!      (match-one v p g+s sk fk i))
!     ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
!      (if (pair? v)
!        (match-one v
!                   (p . tmp)
!                   (match-quasiquote tmp rest g+s sk fk)
!                   fk
!                   i)
!        fk))
!     ((_ v (quasiquote p) g+s sk fk i . depth)
!      (match-quasiquote v p g+s sk fk i #f . depth))
!     ((_ v (unquote p) g+s sk fk i x . depth)
!      (match-quasiquote v p g+s sk fk i . depth))
!     ((_ v (unquote-splicing p) g+s sk fk i x . depth)
!      (match-quasiquote v p g+s sk fk i . depth))
!     ((_ v (p . q) g+s sk fk i . depth)
!      (if (pair? v)
!        (let ((w (car v)) (x (cdr v)))
!          (match-quasiquote
!           w p g+s
!           (match-quasiquote-step x q g+s sk fk depth)
!           fk i . depth))
!        fk))
!     ((_ v #(elt ...) g+s sk fk i . depth)
!      (if (vector? v)
!        (let ((ls (vector->list v)))
!          (match-quasiquote ls (elt ...) g+s sk fk i . depth))
!        fk))
!     ((_ v x g+s sk fk i . depth)
!      (match-one v 'x g+s sk fk i))))
! 
! (define-syntax match-quasiquote-step
!   (syntax-rules ()
!     ((match-quasiquote-step x q g+s sk fk depth i)
!      (match-quasiquote x q g+s sk fk i . depth))))
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Utilities
! 
! ;; Takes two values and just expands into the first.
! (define-syntax match-drop-ids
!   (syntax-rules ()
!     ((_ expr ids ...) expr)))
! 
! (define-syntax match-drop-first-arg
!   (syntax-rules ()
!     ((_ arg expr) expr)))
! 
! ;; To expand an OR group we try each clause in succession, passing the
! ;; first that succeeds to the success continuation.  On failure for
! ;; any clause, we just try the next clause, finally resorting to the
! ;; failure continuation fk if all clauses fail.  The only trick is
! ;; that we want to unify the identifiers, so that the success
! ;; continuation can refer to a variable from any of the OR clauses.
! 
! (define-syntax match-gen-or
!   (syntax-rules ()
!     ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
!      (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
!        (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
! 
! (define-syntax match-gen-or-step
!   (syntax-rules ()
!     ((_ v () g+s sk fk . x)
!      ;; no OR clauses, call the failure continuation
!      fk)
!     ((_ v (p) . x)
!      ;; last (or only) OR clause, just expand normally
!      (match-one v p . x))
!     ((_ v (p . q) g+s sk fk i)
!      ;; match one and try the remaining on failure
!      (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
!     ))
! 
! ;; We match a pattern (p ...) by matching the pattern p in a loop on
! ;; each element of the variable, accumulating the bound ids into lists.
! 
! ;; Look at the body of the simple case - it's just a named let loop,
! ;; matching each element in turn to the same pattern.  The only trick
! ;; is that we want to keep track of the lists of each extracted id, so
! ;; when the loop recurses we cons the ids onto their respective list
! ;; variables, and on success we bind the ids (what the user input and
! ;; expects to see in the success body) to the reversed accumulated
! ;; list IDs.
! 
! (define-syntax match-gen-ellipses
!   (syntax-rules ()
!     ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
!      (match-check-identifier p
!        ;; simplest case equivalent to (p ...), just bind the list
!        (let ((p v))
!          (if (list? p)
!              (sk ... i)
!              fk))
!        ;; simple case, match all elements of the list
!        (let loop ((ls v) (id-ls '()) ...)
!          (cond
!            ((null? ls)
!             (let ((id (reverse id-ls)) ...) (sk ... i)))
!            ((pair? ls)
!             (let ((w (car ls)))
!               (match-one w p ((car ls) (set-car! ls))
!                          (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
!                          fk i)))
!            (else
!             fk)))))
!     ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
!      ;; general case, trailing patterns to match, keep track of the
!      ;; remaining list length so we don't need any backtracking
!      (match-verify-no-ellipses
!       r
!       (let* ((tail-len (length 'r))
!              (ls v)
!              (len (length ls)))
!         (if (< len tail-len)
!             fk
!             (let loop ((ls ls) (n len) (id-ls '()) ...)
!               (cond
!                 ((= n tail-len)
!                  (let ((id (reverse id-ls)) ...)
!                    (match-one ls r (#f #f) (sk ... i) fk i)))
!                 ((pair? ls)
!                  (let ((w (car ls)))
!                    (match-one w p ((car ls) (set-car! ls))
!                               (match-drop-ids
!                                (loop (cdr ls) (- n 1) (cons id id-ls) ...))
!                               fk
!                               i)))
!                 (else
!                  fk)))))))))
! 
! ;; This is just a safety check.  Although unlike syntax-rules we allow
! ;; trailing patterns after an ellipses, we explicitly disable multiple
! ;; ellipses at the same level.  This is because in the general case
! ;; such patterns are exponential in the number of ellipses, and we
! ;; don't want to make it easy to construct very expensive operations
! ;; with simple looking patterns.  For example, it would be O(n^2) for
! ;; patterns like (a ... b ...) because we must consider every trailing
! ;; element for every possible break for the leading "a ...".
! 
! (define-syntax match-verify-no-ellipses
!   (syntax-rules ()
!     ((_ (x . y) sk)
!      (match-check-ellipse
!       x
!       (match-syntax-error
!        "multiple ellipse patterns not allowed at same level")
!       (match-verify-no-ellipses y sk)))
!     ((_ () sk)
!      sk)
!     ((_ x sk)
!      (match-syntax-error "dotted tail not allowed after ellipse" x))))
! 
! ;; Matching a tree search pattern is only slightly more complicated.
! ;; Here we allow patterns of the form
! ;;
! ;;     (x *** y)
! ;;
! ;; to represent the pattern y located somewhere in a tree where the
! ;; path from the current object to y can be seen as a list of the form
! ;; (X ...).  Y can immediately match the current object in which case
! ;; the path is the empty list.  In a sense it's a 2-dimensional
! ;; version of the ... pattern.
! ;;
! ;; As a common case the pattern (_ *** y) can be used to search for Y
! ;; anywhere in a tree, regardless of the path used.
! ;;
! ;; To implement the search, we use two recursive procedures.  TRY
! ;; attempts to match Y once, and on success it calls the normal SK on
! ;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
! ;; call NEXT which first checks if the current value is a list
! ;; beginning with X, then calls TRY on each remaining element of the
! ;; list.  Since TRY will recursively call NEXT again on failure, this
! ;; effects a full depth-first search.
! ;;
! ;; The failure continuation throughout is a jump to the next step in
! ;; the tree search, initialized with the original failure continuation
! ;; FK.
! 
! (define-syntax match-gen-search
!   (syntax-rules ()
!     ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
!      (letrec ((try (lambda (w fail id-ls ...)
!                      (match-one w q g+s
!                                 (match-drop-ids
!                                  (let ((id (reverse id-ls)) ...)
!                                    sk))
!                                 (next w fail id-ls ...) i)))
!               (next (lambda (w fail id-ls ...)
!                       (if (not (pair? w))
!                           (fail)
!                           (let ((u (car w)))
!                             (match-one
!                              u p ((car w) (set-car! w))
!                              (match-drop-ids
!                               ;; accumulate the head variables from
!                               ;; the p pattern, and loop over the tail
!                               (let ((id-ls (cons id id-ls)) ...)
!                                 (let lp ((ls (cdr w)))
!                                   (if (pair? ls)
!                                       (try (car ls)
!                                            (lambda () (lp (cdr ls)))
!                                            id-ls ...)
!                                       (fail)))))
!                              (fail) i))))))
!        ;; the initial id-ls binding here is a dummy to get the right
!        ;; number of '()s
!        (let ((id-ls '()) ...)
!          (try v (lambda () fk) id-ls ...))))))
! 
! ;; Vector patterns are just more of the same, with the slight
! ;; exception that we pass around the current vector index being
! ;; matched.
! 
! (define-syntax match-vector
!   (syntax-rules (___)
!     ((_ v n pats (p q) . x)
!      (match-check-ellipse q
!                           (match-gen-vector-ellipses v n pats p . x)
!                           (match-vector-two v n pats (p q) . x)))
!     ((_ v n pats (p ___) sk fk i)
!      (match-gen-vector-ellipses v n pats p sk fk i))
!     ((_ . x)
!      (match-vector-two . x))))
! 
! ;; Check the exact vector length, then check each element in turn.
! 
! (define-syntax match-vector-two
!   (syntax-rules ()
!     ((_ v n ((pat index) ...) () sk fk i)
!      (if (vector? v)
!          (let ((len (vector-length v)))
!            (if (= len n)
!                (match-vector-step v ((pat index) ...) sk fk i)
!                fk))
!          fk))
!     ((_ v n (pats ...) (p . q) . x)
!      (match-vector v (+ n 1) (pats ... (p n)) q . x))))
! 
! (define-syntax match-vector-step
!   (syntax-rules ()
!     ((_ v () (sk ...) fk i) (sk ... i))
!     ((_ v ((pat index) . rest) sk fk i)
!      (let ((w (vector-ref v index)))
!        (match-one w pat ((vector-ref v index) (vector-set! v index))
!                   (match-vector-step v rest sk fk)
!                   fk i)))))
! 
! ;; With a vector ellipse pattern we first check to see if the vector
! ;; length is at least the required length.
! 
! (define-syntax match-gen-vector-ellipses
!   (syntax-rules ()
!     ((_ v n ((pat index) ...) p sk fk i)
!      (if (vector? v)
!        (let ((len (vector-length v)))
!          (if (>= len n)
!            (match-vector-step v ((pat index) ...)
!                               (match-vector-tail v p n len sk fk)
!                               fk i)
!            fk))
!        fk))))
! 
! (define-syntax match-vector-tail
!   (syntax-rules ()
!     ((_ v p n len sk fk i)
!      (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
! 
! (define-syntax match-vector-tail-two
!   (syntax-rules ()
!     ((_ v p n len (sk ...) fk i ((id id-ls) ...))
!      (let loop ((j n) (id-ls '()) ...)
!        (if (>= j len)
!          (let ((id (reverse id-ls)) ...) (sk ... i))
!          (let ((w (vector-ref v j)))
!            (match-one w p ((vector-ref v j) (vetor-set! v j))
!                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
!                       fk i)))))))
! 
! ;; Extract all identifiers in a pattern.  A little more complicated
! ;; than just looking for symbols, we need to ignore special keywords
! ;; and non-pattern forms (such as the predicate expression in ?
! ;; patterns), and also ignore previously bound identifiers.
! ;;
! ;; Calls the continuation with all new vars as a list of the form
! ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
! ;; pair with the original variable (e.g. it's used in the ellipse
! ;; generation for list variables).
! ;;
! ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
! 
! (define-syntax match-extract-vars
!   (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
!     ((match-extract-vars (? pred . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars ($ rec . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= proc p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= u m p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (quote x) (k ...) i v)
!      (k ... v))
!     ((match-extract-vars (quasiquote x) k i v)
!      (match-extract-quasiquote-vars x k i v (#t)))
!     ((match-extract-vars (and . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (or . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (not . p) . x)
!      (match-extract-vars p . x))
!     ;; A non-keyword pair, expand the CAR with a continuation to
!     ;; expand the CDR.
!     ((match-extract-vars (p q . r) k i v)
!      (match-check-ellipse
!       q
!       (match-extract-vars (p . r) k i v)
!       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
!     ((match-extract-vars (p . q) k i v)
!      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
!     ((match-extract-vars #(p ...) . x)
!      (match-extract-vars (p ...) . x))
!     ((match-extract-vars _ (k ...) i v)    (k ... v))
!     ((match-extract-vars ___ (k ...) i v)  (k ... v))
!     ((match-extract-vars *** (k ...) i v)  (k ... v))
!     ;; This is the main part, the only place where we might add a new
!     ;; var if it's an unbound symbol.
!     ((match-extract-vars p (k ...) (i ...) v)
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (i ...)
!              ((new-sym? p sk fk) sk)
!              ((new-sym? x sk fk) fk))))
!        (new-sym? random-sym-to-match
!                  (k ... ((p p-ls) . v))
!                  (k ... v))))
!     ))
! 
! ;; Stepper used in the above so it can expand the CAR and CDR
! ;; separately.
! 
! (define-syntax match-extract-vars-step
!   (syntax-rules ()
!     ((_ p k i v ((v2 v2-ls) ...))
!      (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
!     ))
! 
! (define-syntax match-extract-quasiquote-vars
!   (syntax-rules (quasiquote unquote unquote-splicing)
!     ((match-extract-quasiquote-vars (quasiquote x) k i v d)
!      (match-extract-quasiquote-vars x k i v (#t . d)))
!     ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
!      (match-extract-quasiquote-vars (unquote x) k i v d))
!     ((match-extract-quasiquote-vars (unquote x) k i v (#t))
!      (match-extract-vars x k i v))
!     ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
!      (match-extract-quasiquote-vars x k i v d))
!     ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
!      (match-extract-quasiquote-vars
!       x
!       (match-extract-quasiquote-vars-step y k i v d) i ()))
!     ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
!      (match-extract-quasiquote-vars (x ...) k i v d))
!     ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
!      (k ... v))
!     ))
! 
! (define-syntax match-extract-quasiquote-vars-step
!   (syntax-rules ()
!     ((_ x k i v d ((v2 v2-ls) ...))
!      (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
!     ))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Gimme some sugar baby.
! (define-syntax match-lambda
!   (syntax-rules ()
!     ((_ clause ...) (lambda (expr) (match expr clause ...)))))
! 
! (define-syntax match-lambda*
!   (syntax-rules ()
!     ((_ clause ...) (lambda expr (match expr clause ...)))))
! 
! (define-syntax match-let
!   (syntax-rules ()
!     ((_ (vars ...) . body)
!      (match-let/helper let () () (vars ...) . body))
!     ((_ loop . rest)
!      (match-named-let loop () . rest))))
! 
! (define-syntax match-letrec
!   (syntax-rules ()
!     ((_ vars . body) (match-let/helper letrec () () vars . body))))
! 
! (define-syntax match-let/helper
!   (syntax-rules ()
!     ((_ let ((var expr) ...) () () . body)
!      (let ((var expr) ...) . body))
!     ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
!      (let ((var expr) ...)
!        (match-let* ((pat tmp) ...)
!          . body)))
!     ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
!      (match-let/helper
!       let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
!     ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
!      (match-let/helper
!       let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
!     ((_ let (v ...) (p ...) ((a expr) . rest) . body)
!      (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
! 
! (define-syntax match-named-let
!   (syntax-rules ()
!     ((_ loop ((pat expr var) ...) () . body)
!      (let loop ((var expr) ...)
!        (match-let ((pat var) ...)
!          . body)))
!     ((_ loop (v ...) ((pat expr) . rest) . body)
!      (match-named-let loop (v ... (pat expr tmp)) rest . body))))
! 
! (define-syntax match-let*
!   (syntax-rules ()
!     ((_ () . body)
!      (begin . body))
!     ((_ ((pat expr) . rest) . body)
!      (match expr (pat (match-let* rest . body))))))
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Otherwise COND-EXPANDed bits.
! 
! ;; This *should* work, but doesn't :(
! ;;   (define-syntax match-check-ellipse
! ;;     (syntax-rules (...)
! ;;       ((_ ... sk fk) sk)
! ;;       ((_ x sk fk) fk)))
! 
! ;; This is a little more complicated, and introduces a new let-syntax,
! ;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
! ;; originally came up with the idea.
! (define-syntax match-check-ellipse
!   (syntax-rules ()
!     ;; these two aren't necessary but provide fast-case failures
!     ((match-check-ellipse (a . b) success-k failure-k) failure-k)
!     ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
!     ;; matching an atom
!     ((match-check-ellipse id success-k failure-k)
!      (let-syntax ((ellipse? (syntax-rules ()
!                               ;; iff `id' is `...' here then this will
!                               ;; match a list of any length
!                               ((ellipse? (foo id) sk fk) sk)
!                               ((ellipse? other sk fk) fk))))
!        ;; this list of three elements will only many the (foo id) list
!        ;; above if `id' is `...'
!        (ellipse? (a b c) success-k failure-k)))))
! 
! 
! ;; This is portable but can be more efficient with non-portable
! ;; extensions.  This trick was originally discovered by Oleg Kiselyov.
! 
! (define-syntax match-check-identifier
!   (syntax-rules ()
!     ;; fast-case failures, lists and vectors are not identifiers
!     ((_ (x . y) success-k failure-k) failure-k)
!     ((_ #(x ...) success-k failure-k) failure-k)
!     ;; x is an atom
!     ((_ x success-k failure-k)
!      (let-syntax
!          ((sym?
!            (syntax-rules ()
!              ;; if the symbol `abracadabra' matches x, then x is a
!              ;; symbol
!              ((sym? x sk fk) sk)
!              ;; otherwise x is a non-symbol datum
!              ((sym? y sk fk) fk))))
!        (sym? abracadabra success-k failure-k)))))
! 
! (defmacro match-define (arg code)
!   (let* ((vars  (macroexpand `(match-extract-vars ,arg () () ())))
! 	 (vars  (map car (car vars)))
! 	 (vars2 (map (lambda (x)    (gensym "x"))   vars))
! 	 (sets  (map (lambda (x y) `(set! ,x ,y))   vars2 vars))
! 	 (sets2 (map (lambda (x y) `(set! ,x ,y))   vars  vars2))
! 	 (lets  (map (lambda (x)   `(,x #f))        vars2))
! 	 (defs  (map (lambda (x)   `(define ,x #f)) vars)))
!     
!     `(begin
!        ,@defs
!        (let ,lets
! 	 (match ,code (,arg (begin ,@sets)))
! 	 ,@sets2))))
! 

Re: fmatch

[Ludovic Courtès]

Hello Stefan!

stefan <stefan.tampe@spray.se> writes:

>> > On a side note I have not gotten any answer from the author of that code
>> > that I modified.
>> 
>> Hmm that’s unfortunate.
> Yes, maybe ask on irc? what channel?

Personal email should be OK, or you could send a message with the patch
that adds support for record-matching attached (with Guile-specific
parts suitably isolated with ‘cond-expand’) and Cc: guile-devel.

We should make it as simple as possible for him to deal with.  It could
be that he’s not interested in it, which is fine.

>> If we can’t get record-matching included upstream shortly, then I’d
>> suggest making the addition of record-matching a separate commit in our
>> repository, so we can easily find it in the future.
>
> Separate commit?

That is: first commit the switch form Wright’s to Shinn’s match
*unmodified*.  Then, commit support for record-matching, separately.

> Ludo, I'm relly a beginner in some respects so be patient :-)

No problem!  :-)

Thanks,
Ludo’.

Re: fmatch

[Ludovic Courtès]

Hello!

stefan <stefan.tampe@spray.se> writes:

> On Saturday 22 May 2010 11:03:12 pm Ludovic Courtès wrote:
>> Hi!
>> 
>> stefan <stefan.tampe@spray.se> writes:
>> > Shall we say that we use the slightly modified version of (ice-9 match)
>> > that ypu dug up for now!
>> 
>> Hmm, yes?  Please send an actual patch against Guile master, so we have
>> something concrete do discuss.  :-)
>
> In this mail a patch is made for discussions. It's not upstream ready
> but intended for further discussions.

Thanks!  Your patch inserts a modified version of Shinn’s match as
(ice-9 match).  I’d prefer to have the upstream version unmodified, say
as ‘match.upstream.scm’, and have ‘match.scm’ just ‘include-from-path’
that file, along with defining any necessary macros for compatibility
(see, e.g., how ‘sxml/ssax.scm’ does that.)

Could you look into it?

Thanks,
Ludo’.

Re: fmatch

[stefan]

[-- Attachment #1: Type: Text/Plain, Size: 1058 bytes --]

is this better?

/Stefan

On Monday 24 May 2010 10:08:58 pm Ludovic Courtès wrote:
> Hello!
> 
> stefan <stefan.tampe@spray.se> writes:
> > On Saturday 22 May 2010 11:03:12 pm Ludovic Courtès wrote:
> >> Hi!
> >>
> >> stefan <stefan.tampe@spray.se> writes:
> >> > Shall we say that we use the slightly modified version of (ice-9
> >> > match) that ypu dug up for now!
> >>
> >> Hmm, yes?  Please send an actual patch against Guile master, so we have
> >> something concrete do discuss.  :-)
> >
> > In this mail a patch is made for discussions. It's not upstream ready
> > but intended for further discussions.
> 
> Thanks!  Your patch inserts a modified version of Shinn’s match as
> (ice-9 match).  I’d prefer to have the upstream version unmodified, say
> as ‘match.upstream.scm’, and have ‘match.scm’ just ‘include-from-path’
> that file, along with defining any necessary macros for compatibility
> (see, e.g., how ‘sxml/ssax.scm’ does that.)
> 
> Could you look into it?
> 
> Thanks,
> Ludo’.
> 

[-- Attachment #2: match.patch --]
[-- Type: text/x-patch, Size: 65825 bytes --]

Only in guile-master-20100512_new//examples: match_examples.scm
diff -crB guile-master-20100512/module/ice-9/match.scm guile-master-20100512_new//module/ice-9/match.scm
*** guile-master-20100512/module/ice-9/match.scm	2010-05-12 06:00:07.000000000 +0200
--- guile-master-20100512_new//module/ice-9/match.scm	2010-05-24 23:04:17.408064463 +0200
***************
*** 1,199 ****
! ;;; installed-scm-file
! 
! ;;;; 	Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
! ;;;;
! ;;;; This library is free software; you can redistribute it and/or
! ;;;; modify it under the terms of the GNU Lesser General Public
! ;;;; License as published by the Free Software Foundation; either
! ;;;; version 3 of the License, or (at your option) any later version.
! ;;;; 
! ;;;; This library 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
! ;;;; Lesser General Public License for more details.
! ;;;; 
! ;;;; You should have received a copy of the GNU Lesser General Public
! ;;;; License along with this library; if not, write to the Free Software
! ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ;;;;
  
  (define-module (ice-9 match)
!   :use-module (ice-9 pretty-print)
!   :export (match match-lambda match-lambda* match-define
! 		 match-let match-let* match-letrec
! 		 define-structure define-const-structure
!                  match:andmap
! 		 match:error match:set-error
! 		 match:error-control match:set-error-control
! 		 match:structure-control match:set-structure-control
! 		 match:runtime-structures match:set-runtime-structures))
! 
! ;; The original code can be found at the Scheme Repository
! ;;
! ;;   http://www.cs.indiana.edu/scheme-repository/code.match.html
! ;;
! ;; or Andrew K. Wright's web page:
! ;;
! ;;   http://www.star-lab.com/wright/code.html
! 
! \f
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Pattern Matching Syntactic Extensions for Scheme
! ;;
! (define match:version "Version 1.19, Sep 15, 1995")
! ;;
! ;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
! ;; Adapted from code originally written by Bruce F. Duba, 1991.
! ;; This package also includes a modified version of Kent Dybvig's
! ;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
! ;; Prentice-Hall, NJ, 1987).
! ;;
! ;; This macro package extends Scheme with several new expression forms.
! ;; Following is a brief summary of the new forms.  See the associated
! ;; LaTeX documentation for a full description of their functionality.
! ;;
! ;;
! ;;         match expressions:
! ;;
! ;; exp ::= ...
! ;;       | (match exp clause ...)
! ;;       | (match-lambda clause ...)
! ;;       | (match-lambda* clause ...)
! ;;       | (match-let ((pat exp) ...) body)
! ;;       | (match-let* ((pat exp) ...) body)
! ;;       | (match-letrec ((pat exp) ...) body)
! ;;       | (match-define pat exp)
! ;;
! ;; clause ::= (pat body) | (pat => exp)
! ;;
! ;;         patterns:                       matches:
! ;;
! ;; pat ::= identifier                      anything, and binds identifier
! ;;       | _                               anything
! ;;       | ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | 'sexp                           an s-expression
! ;;       | 'symbol                         a symbol (special case of s-expr)
! ;;       | (pat_1 ... pat_n)               list of n elements
! ;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
! ;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #(pat_1 ... pat_n)              vector of n elements
! ;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #&pat                           box
! ;;       | ($ struct-name pat_1 ... pat_n) a structure
! ;;       | (= field pat)                   a field of a structure
! ;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
! ;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
! ;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
! ;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
! ;;                                           pat_1 thru pat_n match
! ;;       | (set! identifier)               anything, and binds setter
! ;;       | (get! identifier)               anything, and binds getter
! ;;       | `qp                             a quasi-pattern
! ;;
! ;; ooo ::= ...                             zero or more
! ;;       | ___                             zero or more
! ;;       | ..k                             k or more
! ;;       | __k                             k or more
! ;;
! ;;         quasi-patterns:                 matches:
! ;;
! ;; qp  ::= ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | identifier                      a symbol
! ;;       | (qp_1 ... qp_n)                 list of n elements
! ;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
! ;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #(qp_1 ... qp_n)                vector of n elements
! ;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #&qp                            box
! ;;       | ,pat                            a pattern
! ;;       | ,@pat                           a pattern
! ;;
! ;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
! ;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
! ;;
! ;;
! ;;         structure expressions:
! ;;
! ;; exp ::= ...
! ;;       | (define-structure (id_0 id_1 ... id_n))
! ;;       | (define-structure (id_0 id_1 ... id_n)
! ;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n)
! ;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
! ;;
! ;; arg ::= id | (! id) | (@ id)
! ;;
! ;;
! ;; match:error-control controls what code is generated for failed matches.
! ;; Possible values:
! ;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
! ;;  'fail - call match:error, or die at car or cdr
! ;;  'error - call match:error with the unmatched value
! ;;  'match - call match:error with the unmatched value _and_
! ;;             the quoted match expression
! ;; match:error-control is set by calling match:set-error-control with
! ;; the new value.
! ;;
! ;; match:error is called for a failed match.
! ;; match:error is set by calling match:set-error with the new value.
! ;;
! ;; match:structure-control controls the uniqueness of structures
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  'vector - (default) structures are vectors with a symbol in position 0
! ;;  'disjoint - structures are fully disjoint from all other values
! ;; match:structure-control is set by calling match:set-structure-control
! ;; with the new value.
! ;;
! ;; match:runtime-structures controls whether local structure declarations
! ;; generate new structures each time they are reached
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  #t - (default) each runtime occurrence generates a new structure
! ;;  #f - each lexical occurrence generates a new structure
! ;;
! ;; End of user visible/modifiable stuff.
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! (define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
! (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
! (define match:syntax-err (lambda (obj msg) (error msg obj)))
! (define match:disjoint-structure-tags (quote ()))
! (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
! (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
! (define match:structure-control (quote vector))
! (define match:set-structure-control (lambda (v) (set! match:structure-control v)))
! (define match:set-error (lambda (v) (set! match:error v)))
! (define match:error-control (quote error))
! (define match:set-error-control (lambda (v) (set! match:error-control v)))
! (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
! (define match:vector-structures (quote ()))
! (define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
! (defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
! (defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
! (defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
! (defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
! (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
! (defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
! (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
! (define match:runtime-structures #f)
! (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
! (define match:primitive-vector? vector?)
! (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
! (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
! (defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
--- 1,222 ----
! ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
! ;; Modifying upstream version (match.upstream.scm) by Alex Shinn
  
  (define-module (ice-9 match)
!   #:use-module (srfi srfi-9)
!   #:export     (match-define match-let* match-let match-letrec match-lambda*
! 			     match-lambda match))
! 
! (define-syntax match
!   (syntax-rules ()
!     ((match)
!      (match-syntax-error "missing match expression"))
!     ((match atom)
!      (match-syntax-error "no match clauses"))
!     ((match (app ...) (pat . body) ...)
!      (let ((v (app ...)))
!        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
!     ((match #(vec ...) (pat . body) ...)
!      (let ((v #(vec ...)))
!        (match-next v (v (set! v)) (pat . body) ...)))
!     ((match atom (pat . body) ...)
!      (let ((v atom))
!        (match-next v (atom (set! atom)) (pat . body) ...)))
!     ))
! 
! (define-syntax match-two
!   (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
!     ((match-two v () g+s (sk ...) fk i)
!      (if (null? v) (sk ... i) fk))
!     ((match-two v (quote p) g+s (sk ...) fk i)
!      (if (equal? v 'p) (sk ... i) fk))
!     ((match-two v (quasiquote p) . x)
!      (match-quasiquote v p . x))
!     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
!     ((match-two v (and p q ...) g+s sk fk i)
!      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
!     ((match-two v (or) g+s sk fk i) fk)
!     ((match-two v (or p) . x)
!      (match-one v p . x))
!     ((match-two v (or p ...) g+s sk fk i)
!      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
!     ((match-two v (not p) g+s (sk ...) fk i)
!      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
!     ((match-two v (get! getter) (g s) (sk ...) fk i)
!      (let ((getter (lambda () g))) (sk ... i)))
!     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
!      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
!     ((match-two v (? pred . p) g+s sk fk i)
!      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
!     
!     ;; stis, added $ support!
!     ((match-two v ($ n) g-s sk fk i)
!      (if (n v) sk fk))
!     
!     ((match-two v ($ nn p ...) g+s sk fk i)
!      (if (nn v)
! 	 (match-$ (and) 0 (p ...) v sk fk i)
! 	 fk))
!      
!     ;; stis, added the possibility to use set! and get to records    
!     ((match-two v (= 0 m p) g+s sk fk i)
!      (let ((w  (struct-ref v m)))
!        (match-one w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
! 
!     ((match-two v (= g s p) g+s sk fk i)
!      (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i)))
! 
!     ((match-two v (= proc p) g+s . x)
!      (let ((w (proc v))) '() (match-one w p . x)))
!     
!     ((match-two v (p ___ . r) g+s sk fk i)
!      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
!     ((match-two v (p) g+s sk fk i)
!      (if (and (pair? v) (null? (cdr v)))
!          (let ((w (car v)))
!            (match-one w p ((car v) (set-car! v)) sk fk i))
!          fk))
!     ((match-two v (p *** q) g+s sk fk i)
!      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
!     ((match-two v (p *** . q) g+s sk fk i)
!      (match-syntax-error "invalid use of ***" (p *** . q)))
!     ((match-two v (p . q) g+s sk fk i)
!      (if (pair? v)
!          (let ((w (car v)) (x (cdr v)))
!            (match-one w p ((car v) (set-car! v))
!                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
!                       fk
!                       i))
!          fk))
!     ((match-two v #(p ...) g+s . x)
!      (match-vector v 0 () (p ...) . x))
!     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
!     ;; Not a pair or vector or special literal, test to see if it's a
!     ;; new symbol, in which case we just bind it, or if it's an
!     ;; already bound symbol or some other literal, in which case we
!     ;; compare it with EQUAL?.
!     ((match-two v x g+s (sk ...) fk (id ...))
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (id ...)
!              ((new-sym? x sk2 fk2) sk2)
!              ((new-sym? y sk2 fk2) fk2))))
!        (new-sym? random-sym-to-match
!                  (let ((x v)) (sk ... (id ... x)))
!                  (if (equal? v x) (sk ... (id ...)) fk))))
!     ))
! 
! (define-syntax match-$
!   (lambda (x)
!     (syntax-case x ()
!       ((q (a ...) m (p1 p2 ...) . v)
!        (with-syntax ((m+1 (datum->syntax (syntax q) 
! 					 (+ (syntax->datum (syntax m)) 1))))
! 	 (syntax (match-$ (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
!       ((_ newpat  m ()            v kt ke i)
!        (syntax (match-one v newpat () kt ke i))))))
! 
! ;;We must be able to extract vars in the new constructs!!
! (define-syntax match-extract-vars
!   (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
!     ((match-extract-vars (? pred . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars ($ rec . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= proc p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= u m p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (quote x) (k ...) i v)
!      (k ... v))
!     ((match-extract-vars (quasiquote x) k i v)
!      (match-extract-quasiquote-vars x k i v (#t)))
!     ((match-extract-vars (and . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (or . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (not . p) . x)
!      (match-extract-vars p . x))
!     ;; A non-keyword pair, expand the CAR with a continuation to
!     ;; expand the CDR.
!     ((match-extract-vars (p q . r) k i v)
!      (match-check-ellipse
!       q
!       (match-extract-vars (p . r) k i v)
!       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
!     ((match-extract-vars (p . q) k i v)
!      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
!     ((match-extract-vars #(p ...) . x)
!      (match-extract-vars (p ...) . x))
!     ((match-extract-vars _ (k ...) i v)    (k ... v))
!     ((match-extract-vars ___ (k ...) i v)  (k ... v))
!     ((match-extract-vars *** (k ...) i v)  (k ... v))
!     ;; This is the main part, the only place where we might add a new
!     ;; var if it's an unbound symbol.
!     ((match-extract-vars p (k ...) (i ...) v)
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (i ...)
!              ((new-sym? p sk fk) sk)
!              ((new-sym? x sk fk) fk))))
!        (new-sym? random-sym-to-match
!                  (k ... ((p p-ls) . v))
!                  (k ... v))))
!     ))
! 
! (defmacro match-define (arg code)
!   (let* ((vars  (unmemoize-expr
! 		 (macroexpand `((@ (ice-9 match) match-extract-vars) ,arg () () ()))))
! 	 (vars  (map car (car vars)))
! 	 (vars2 (map (lambda (x)    (gensym "x"))   vars))
! 	 (sets  (map (lambda (x y) `(set! ,x ,y))   vars2 vars))
! 	 (sets2 (map (lambda (x y) `(set! ,x ,y))   vars  vars2))
! 	 (lets  (map (lambda (x)   `(,x #f))        vars2))
! 	 (defs  (map (lambda (x)   `(define ,x #f)) vars)))
!     
!     `(begin
!        ,@defs
!        (let ,lets
! 	 (match ,code (,arg (begin ,@sets)))
! 	 ,@sets2))))
! 
! 
! ;;;Reading the rest from upstream
! 
! ;;Utility
! (define-syntax include-from-path/filtered
!   (lambda (x)
!     (define (hit? sexp reject-list)
!       (if (null? reject-list)
! 	  #f
! 	  (let ((h (car reject-list))
! 		(l (cdr reject-list)))
! 	    (if (and (pair? sexp)
! 		     (eq? 'define-syntax (car sexp))
! 		     (pair? (cdr sexp))
! 		     (eq? h (cadr sexp)))
! 		#t
! 		(hit? sexp l)))))
! 
!     (define (read-filtered reject-list file)
!       (with-input-from-file (%search-load-path file)
!         (lambda ()
!           (let loop ((sexp (read)) (out '()))
!             (cond
!              ((eof-object? sexp) (reverse out))
!              ((hit? sexp reject-list)
!               (loop (read) out))
!              (else
!               (loop (read) (cons sexp out))))))))
! 
!     (syntax-case x ()
!       ((_ reject-list file)
!        (with-syntax (((exp ...) (datum->syntax
!                                  x 
!                                  (read-filtered
!                                   (syntax->datum #'reject-list)
!                                   (syntax->datum #'file)))))
! 		    #'(begin exp ...))))))
! 
! (include-from-path/filtered
!  (match-extract-vars match-two match)
!  "ice-9/match.upstream.scm")
\ No newline at end of file
Only in guile-master-20100512_new//module/ice-9: match.scm~
Only in guile-master-20100512_new//module/ice-9: match.upstream.scm

Re: fmatch

[Ludovic Courtès]

Hello,

This patch lacks match.upstream.scm and is not in unidiff format, which
makes it hard for me to read.

Can you generate the patch, e.g., with git, using “git diff master” or
some such?

Thanks,
Ludo’.

Re: fmatch

[stefan]

[-- Attachment #1: Type: Text/Plain, Size: 598 bytes --]

On Tuesday 25 May 2010 07:41:57 pm Ludovic Courtès wrote:
> Hello,
> 
> This patch lacks match.upstream.scm and is not in unidiff format, which
> makes it hard for me to read.
> 
> Can you generate the patch, e.g., with git, using “git diff master” or
> some such?
> 
> Thanks,
> Ludo’.

Yes I've never done this before :-).

Anyway git diff --cached  gives the attached patch file.

Also I made the code less hacky by using define-syntax in stead
of a defmacro and macroexpand for the defin-syntax sugar (oh hacker). 
It was a litle more work then I expected.

/Stefan

[-- Attachment #2: ice-9-match.patch --]
[-- Type: text/x-patch, Size: 93072 bytes --]

diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index d758923..1a2a61e 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -1,199 +1,245 @@
-;;; installed-scm-file
-
-;;;; 	Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;; 
-;;;; This library 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
-;;;; Lesser General Public License for more details.
-;;;; 
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
+;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
+;; Modifying upstream version (match.upstream.scm) by Alex Shinn
 
 (define-module (ice-9 match)
-  :use-module (ice-9 pretty-print)
-  :export (match match-lambda match-lambda* match-define
-		 match-let match-let* match-letrec
-		 define-structure define-const-structure
-                 match:andmap
-		 match:error match:set-error
-		 match:error-control match:set-error-control
-		 match:structure-control match:set-structure-control
-		 match:runtime-structures match:set-runtime-structures))
-
-;; The original code can be found at the Scheme Repository
-;;
-;;   http://www.cs.indiana.edu/scheme-repository/code.match.html
-;;
-;; or Andrew K. Wright's web page:
-;;
-;;   http://www.star-lab.com/wright/code.html
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Pattern Matching Syntactic Extensions for Scheme
-;;
-(define match:version "Version 1.19, Sep 15, 1995")
-;;
-;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
-;; Adapted from code originally written by Bruce F. Duba, 1991.
-;; This package also includes a modified version of Kent Dybvig's
-;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
-;; Prentice-Hall, NJ, 1987).
-;;
-;; This macro package extends Scheme with several new expression forms.
-;; Following is a brief summary of the new forms.  See the associated
-;; LaTeX documentation for a full description of their functionality.
-;;
-;;
-;;         match expressions:
-;;
-;; exp ::= ...
-;;       | (match exp clause ...)
-;;       | (match-lambda clause ...)
-;;       | (match-lambda* clause ...)
-;;       | (match-let ((pat exp) ...) body)
-;;       | (match-let* ((pat exp) ...) body)
-;;       | (match-letrec ((pat exp) ...) body)
-;;       | (match-define pat exp)
-;;
-;; clause ::= (pat body) | (pat => exp)
-;;
-;;         patterns:                       matches:
-;;
-;; pat ::= identifier                      anything, and binds identifier
-;;       | _                               anything
-;;       | ()                              the empty list
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | 'sexp                           an s-expression
-;;       | 'symbol                         a symbol (special case of s-expr)
-;;       | (pat_1 ... pat_n)               list of n elements
-;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
-;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
-;;                                           of remainder must match pat_n+1
-;;       | #(pat_1 ... pat_n)              vector of n elements
-;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
-;;                                           of remainder must match pat_n+1
-;;       | #&pat                           box
-;;       | ($ struct-name pat_1 ... pat_n) a structure
-;;       | (= field pat)                   a field of a structure
-;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
-;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
-;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
-;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
-;;                                           pat_1 thru pat_n match
-;;       | (set! identifier)               anything, and binds setter
-;;       | (get! identifier)               anything, and binds getter
-;;       | `qp                             a quasi-pattern
-;;
-;; ooo ::= ...                             zero or more
-;;       | ___                             zero or more
-;;       | ..k                             k or more
-;;       | __k                             k or more
-;;
-;;         quasi-patterns:                 matches:
-;;
-;; qp  ::= ()                              the empty list
-;;       | #t                              #t
-;;       | #f                              #f
-;;       | string                          a string
-;;       | number                          a number
-;;       | character                       a character
-;;       | identifier                      a symbol
-;;       | (qp_1 ... qp_n)                 list of n elements
-;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
-;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #(qp_1 ... qp_n)                vector of n elements
-;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
-;;                                           of remainder must match qp_n+1
-;;       | #&qp                            box
-;;       | ,pat                            a pattern
-;;       | ,@pat                           a pattern
-;;
-;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
-;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
-;;
-;;
-;;         structure expressions:
-;;
-;; exp ::= ...
-;;       | (define-structure (id_0 id_1 ... id_n))
-;;       | (define-structure (id_0 id_1 ... id_n)
-;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
-;;       | (define-const-structure (id_0 arg_1 ... arg_n))
-;;       | (define-const-structure (id_0 arg_1 ... arg_n)
-;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
-;;
-;; arg ::= id | (! id) | (@ id)
-;;
-;;
-;; match:error-control controls what code is generated for failed matches.
-;; Possible values:
-;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
-;;  'fail - call match:error, or die at car or cdr
-;;  'error - call match:error with the unmatched value
-;;  'match - call match:error with the unmatched value _and_
-;;             the quoted match expression
-;; match:error-control is set by calling match:set-error-control with
-;; the new value.
-;;
-;; match:error is called for a failed match.
-;; match:error is set by calling match:set-error with the new value.
-;;
-;; match:structure-control controls the uniqueness of structures
-;; (does not exist for Scheme 48 version).
-;; Possible values:
-;;  'vector - (default) structures are vectors with a symbol in position 0
-;;  'disjoint - structures are fully disjoint from all other values
-;; match:structure-control is set by calling match:set-structure-control
-;; with the new value.
-;;
-;; match:runtime-structures controls whether local structure declarations
-;; generate new structures each time they are reached
-;; (does not exist for Scheme 48 version).
-;; Possible values:
-;;  #t - (default) each runtime occurrence generates a new structure
-;;  #f - each lexical occurrence generates a new structure
-;;
-;; End of user visible/modifiable stuff.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
-(define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
-(define match:syntax-err (lambda (obj msg) (error msg obj)))
-(define match:disjoint-structure-tags (quote ()))
-(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
-(define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
-(define match:structure-control (quote vector))
-(define match:set-structure-control (lambda (v) (set! match:structure-control v)))
-(define match:set-error (lambda (v) (set! match:error v)))
-(define match:error-control (quote error))
-(define match:set-error-control (lambda (v) (set! match:error-control v)))
-(define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
-(define match:vector-structures (quote ()))
-(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
-(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
-(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
-(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
-(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
-(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
-(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
-(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
-(define match:runtime-structures #f)
-(define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
-(define match:primitive-vector? vector?)
-(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
-(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
-(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
+  #:use-module (srfi srfi-9)
+  #:export     (match-define match-let* match-let match-letrec match-lambda*
+			     match-lambda match))
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (let ((v atom))
+       (match-next v (atom (set! atom)) (pat . body) ...)))
+    ))
+
+(define-syntax match-two
+  (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
+    ((match-two v () g+s (sk ...) fk i)
+     (if (null? v) (sk ... i) fk))
+    ((match-two v (quote p) g+s (sk ...) fk i)
+     (if (equal? v 'p) (sk ... i) fk))
+    ((match-two v (quasiquote p) . x)
+     (match-quasiquote v p . x))
+    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
+    ((match-two v (and p q ...) g+s sk fk i)
+     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
+    ((match-two v (or) g+s sk fk i) fk)
+    ((match-two v (or p) . x)
+     (match-one v p . x))
+    ((match-two v (or p ...) g+s sk fk i)
+     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
+    ((match-two v (not p) g+s (sk ...) fk i)
+     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+    ((match-two v (get! getter) (g s) (sk ...) fk i)
+     (let ((getter (lambda () g))) (sk ... i)))
+    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
+     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+    ((match-two v (? pred . p) g+s sk fk i)
+     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
+    
+    ;; stis, added $ support!
+    ((match-two v ($ n) g-s sk fk i)
+     (if (n v) sk fk))
+    
+    ((match-two v ($ nn p ...) g+s sk fk i)
+     (if (nn v)
+	 (match-$ (and) 0 (p ...) v sk fk i)
+	 fk))
+     
+    ;; stis, added the possibility to use set! and get to records    
+    ((match-two v (= 0 m p) g+s sk fk i)
+     (let ((w  (struct-ref v m)))
+       (match-one w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
+
+    ((match-two v (= g s p) g+s sk fk i)
+     (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i)))
+
+    ((match-two v (= proc p) g+s . x)
+     (let ((w (proc v))) '() (match-one w p . x)))
+    
+    ((match-two v (p ___ . r) g+s sk fk i)
+     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
+    ((match-two v (p) g+s sk fk i)
+     (if (and (pair? v) (null? (cdr v)))
+         (let ((w (car v)))
+           (match-one w p ((car v) (set-car! v)) sk fk i))
+         fk))
+    ((match-two v (p *** q) g+s sk fk i)
+     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
+    ((match-two v (p *** . q) g+s sk fk i)
+     (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v (p . q) g+s sk fk i)
+     (if (pair? v)
+         (let ((w (car v)) (x (cdr v)))
+           (match-one w p ((car v) (set-car! v))
+                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
+                      fk
+                      i))
+         fk))
+    ((match-two v #(p ...) g+s . x)
+     (match-vector v 0 () (p ...) . x))
+    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
+    ;; Not a pair or vector or special literal, test to see if it's a
+    ;; new symbol, in which case we just bind it, or if it's an
+    ;; already bound symbol or some other literal, in which case we
+    ;; compare it with EQUAL?.
+    ((match-two v x g+s (sk ...) fk (id ...))
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (id ...)
+             ((new-sym? x sk2 fk2) sk2)
+             ((new-sym? y sk2 fk2) fk2))))
+       (new-sym? random-sym-to-match
+                 (let ((x v)) (sk ... (id ... x)))
+                 (if (equal? v x) (sk ... (id ...)) fk))))
+    ))
+
+(define-syntax match-$
+  (lambda (x)
+    (syntax-case x ()
+      ((q (a ...) m (p1 p2 ...) . v)
+       (with-syntax ((m+1 (datum->syntax (syntax q) 
+					 (+ (syntax->datum (syntax m)) 1))))
+	 (syntax (match-$ (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
+      ((_ newpat  m ()            v kt ke i)
+       (syntax (match-one v newpat () kt ke i))))))
+
+;;We must be able to extract vars in the new constructs!!
+(define-syntax match-extract-vars
+  (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
+    ((match-extract-vars (? pred . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars ($ rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (= proc p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (= u m p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (quote x) (k ...) i v)
+     (k ... v))
+    ((match-extract-vars (quasiquote x) k i v)
+     (match-extract-quasiquote-vars x k i v (#t)))
+    ((match-extract-vars (and . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (or . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (not . p) . x)
+     (match-extract-vars p . x))
+    ;; A non-keyword pair, expand the CAR with a continuation to
+    ;; expand the CDR.
+    ((match-extract-vars (p q . r) k i v)
+     (match-check-ellipse
+      q
+      (match-extract-vars (p . r) k i v)
+      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+    ((match-extract-vars (p . q) k i v)
+     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+    ((match-extract-vars #(p ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars _ (k ...) i v)    (k ... v))
+    ((match-extract-vars ___ (k ...) i v)  (k ... v))
+    ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ;; This is the main part, the only place where we might add a new
+    ;; var if it's an unbound symbol.
+    ((match-extract-vars p (k ...) (i ...) v)
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (i ...)
+             ((new-sym? p sk fk) sk)
+             ((new-sym? x sk fk) fk))))
+       (new-sym? random-sym-to-match
+                 (k ... ((p p-ls) . v))
+                 (k ... v))))
+    ))
+
+
+
+(define-syntax match-define
+  (syntax-rules ()
+    ((q arg code)
+     (match-extract-vars arg (sieve (match-define-helper0 arg code) ()) () ()))))
+
+(define-syntax sieve
+  (syntax-rules ()
+    ((_ cc (w ...) ((v q) v2 ...))
+     (sieve cc (v w ...) (v2 ...)))
+    ((_ cc (w ...) (v v2 ...))
+     (sieve cc (v w ...) (v2 ...)))
+    ((_ (cc ...) w ())
+     (cc ... w))))
+  
+(define-syntax match-define-helper0
+  (lambda (x)
+    (syntax-case x ()
+      ((q arg code v)
+       (with-syntax ((vtemp (map (lambda (x)
+				   (datum->syntax
+				    (syntax q) (gensym "temp")))
+				 (syntax->datum (syntax v)))))
+	  (syntax (match-define-helper v vtemp arg code)))))))
+
+(define-syntax match-define-helper
+  (syntax-rules ()
+    ((_ (v ...) (vt ...) arg code) 
+     (begin 
+       (begin (define v 0) 
+	      ...)
+       (let ((vt 0) ...)
+	 (match  code 
+		 (arg (begin (set! vt v) 
+			     ...)))
+	 (begin (set! v vt) 
+		...))))))
+
+
+;;;Reading the rest from upstream
+
+;;Utility
+(define-syntax include-from-path/filtered
+  (lambda (x)
+    (define (hit? sexp reject-list)
+      (if (null? reject-list)
+	  #f
+	  (let ((h (car reject-list))
+		(l (cdr reject-list)))
+	    (if (and (pair? sexp)
+		     (eq? 'define-syntax (car sexp))
+		     (pair? (cdr sexp))
+		     (eq? h (cadr sexp)))
+		#t
+		(hit? sexp l)))))
+
+    (define (read-filtered reject-list file)
+      (with-input-from-file (%search-load-path file)
+        (lambda ()
+          (let loop ((sexp (read)) (out '()))
+            (cond
+             ((eof-object? sexp) (reverse out))
+             ((hit? sexp reject-list)
+              (loop (read) out))
+             (else
+              (loop (read) (cons sexp out))))))))
+
+    (syntax-case x ()
+      ((_ reject-list file)
+       (with-syntax (((exp ...) (datum->syntax
+                                 x 
+                                 (read-filtered
+                                  (syntax->datum #'reject-list)
+                                  (syntax->datum #'file)))))
+		    #'(begin exp ...))))))
+
+(include-from-path/filtered
+ (match-extract-vars match-two match)
+ "ice-9/match.upstream.scm")
\ No newline at end of file
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
new file mode 100644
index 0000000..963b89f
--- /dev/null
+++ b/module/ice-9/match.upstream.scm
@@ -0,0 +1,670 @@
+;;;; match.scm -- portable hygienic pattern matcher
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain.  All warranties are disclaimed.
+
+;; This is a full superset of the popular MATCH package by Andrew
+;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
+;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
+
+;; This is a simple generative pattern matcher - each pattern is
+;; expanded into the required tests, calling a failure continuation if
+;; the tests fail.  This makes the logic easy to follow and extend,
+;; but produces sub-optimal code in cases where you have many similar
+;; clauses due to repeating the same tests.  Nonetheless a smart
+;; compiler should be able to remove the redundant tests.  For
+;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
+;; hit.
+
+;; The original version was written on 2006/11/29 and described in the
+;; following Usenet post:
+;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
+;; and is still available at
+;;   http://synthcode.com/scheme/match-simple.scm
+;; It's just 80 lines for the core MATCH, and an extra 40 lines for
+;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
+;;
+;; A variant of this file which uses COND-EXPAND in a few places for
+;; performance can be found at
+;;   http://synthcode.com/scheme/match-cond-expand.scm
+;;
+;; 2009/11/25 - adding `***' tree search patterns
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipse patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
+;;              (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; force compile-time syntax errors with useful messages
+
+(define-syntax match-syntax-error
+  (syntax-rules ()
+    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The basic interface.  MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable `v',
+;; and passes it on to MATCH-NEXT.  It's a constant throughout the
+;; code below that the binding `v' is a direct variable reference, not
+;; an expression.
+
+(define-syntax match
+  (syntax-rules ()
+    ((match)
+     (match-syntax-error "missing match expression"))
+    ((match atom)
+     (match-syntax-error "no match clauses"))
+    ((match (app ...) (pat . body) ...)
+     (let ((v (app ...)))
+       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
+    ((match #(vec ...) (pat . body) ...)
+     (let ((v #(vec ...)))
+       (match-next v (v (set! v)) (pat . body) ...)))
+    ((match atom (pat . body) ...)
+     (match-next atom (atom (set! atom)) (pat . body) ...))
+    ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.  `g+s' is a list of two elements, the get! and set!
+;; expressions respectively.
+
+(define-syntax match-next
+  (syntax-rules (=>)
+    ;; no more clauses, the match failed
+    ((match-next v g+s)
+     (error 'match "no matching pattern"))
+    ;; named failure continuation
+    ((match-next v g+s (pat (=> failure) . body) . rest)
+     (let ((failure (lambda () (match-next v g+s . rest))))
+       ;; match-one analyzes the pattern for us
+       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
+    ;; anonymous failure continuation, give it a dummy name
+    ((match-next v g+s (pat . body) . rest)
+     (match-next v g+s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+  (syntax-rules ()
+    ;; If it's a list of two or more values, check to see if the
+    ;; second one is an ellipse and handle accordingly, otherwise go
+    ;; to MATCH-TWO.
+    ((match-one v (p q . r) g+s sk fk i)
+     (match-check-ellipse
+      q
+      (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
+      (match-two v (p q . r) g+s sk fk i)))
+    ;; Go directly to MATCH-TWO.
+    ((match-one . x)
+     (match-two . x))))
+
+;; This is the guts of the pattern matcher.  We are passed a lot of
+;; information in the form:
+;;
+;;   (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; usually abbreviated
+;;
+;;   (match-two v p g+s sk fk i)
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+  (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
+    ((match-two v () g+s (sk ...) fk i)
+     (if (null? v) (sk ... i) fk))
+    ((match-two v (quote p) g+s (sk ...) fk i)
+     (if (equal? v 'p) (sk ... i) fk))
+    ((match-two v (quasiquote p) . x)
+     (match-quasiquote v p . x))
+    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
+    ((match-two v (and p q ...) g+s sk fk i)
+     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
+    ((match-two v (or) g+s sk fk i) fk)
+    ((match-two v (or p) . x)
+     (match-one v p . x))
+    ((match-two v (or p ...) g+s sk fk i)
+     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
+    ((match-two v (not p) g+s (sk ...) fk i)
+     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
+    ((match-two v (get! getter) (g s) (sk ...) fk i)
+     (let ((getter (lambda () g))) (sk ... i)))
+    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
+     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+    ((match-two v (? pred . p) g+s sk fk i)
+     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
+    ((match-two v (= proc p) . x)
+     (let ((w (proc v))) (match-one w p . x)))
+    ((match-two v (p ___ . r) g+s sk fk i)
+     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
+    ((match-two v (p) g+s sk fk i)
+     (if (and (pair? v) (null? (cdr v)))
+         (let ((w (car v)))
+           (match-one w p ((car v) (set-car! v)) sk fk i))
+         fk))
+    ((match-two v (p *** q) g+s sk fk i)
+     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
+    ((match-two v (p *** . q) g+s sk fk i)
+     (match-syntax-error "invalid use of ***" (p *** . q)))
+    ((match-two v (p . q) g+s sk fk i)
+     (if (pair? v)
+         (let ((w (car v)) (x (cdr v)))
+           (match-one w p ((car v) (set-car! v))
+                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
+                      fk
+                      i))
+         fk))
+    ((match-two v #(p ...) g+s . x)
+     (match-vector v 0 () (p ...) . x))
+    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
+    ;; Not a pair or vector or special literal, test to see if it's a
+    ;; new symbol, in which case we just bind it, or if it's an
+    ;; already bound symbol or some other literal, in which case we
+    ;; compare it with EQUAL?.
+    ((match-two v x g+s (sk ...) fk (id ...))
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (id ...)
+             ((new-sym? x sk2 fk2) sk2)
+             ((new-sym? y sk2 fk2) fk2))))
+       (new-sym? random-sym-to-match
+                 (let ((x v)) (sk ... (id ... x)))
+                 (if (equal? v x) (sk ... (id ...)) fk))))
+    ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+  (syntax-rules (unquote unquote-splicing quasiquote)
+    ((_ v (unquote p) g+s sk fk i)
+     (match-one v p g+s sk fk i))
+    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
+     (if (pair? v)
+       (match-one v
+                  (p . tmp)
+                  (match-quasiquote tmp rest g+s sk fk)
+                  fk
+                  i)
+       fk))
+    ((_ v (quasiquote p) g+s sk fk i . depth)
+     (match-quasiquote v p g+s sk fk i #f . depth))
+    ((_ v (unquote p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
+     (match-quasiquote v p g+s sk fk i . depth))
+    ((_ v (p . q) g+s sk fk i . depth)
+     (if (pair? v)
+       (let ((w (car v)) (x (cdr v)))
+         (match-quasiquote
+          w p g+s
+          (match-quasiquote-step x q g+s sk fk depth)
+          fk i . depth))
+       fk))
+    ((_ v #(elt ...) g+s sk fk i . depth)
+     (if (vector? v)
+       (let ((ls (vector->list v)))
+         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
+       fk))
+    ((_ v x g+s sk fk i . depth)
+     (match-one v 'x g+s sk fk i))))
+
+(define-syntax match-quasiquote-step
+  (syntax-rules ()
+    ((match-quasiquote-step x q g+s sk fk depth i)
+     (match-quasiquote x q g+s sk fk i . depth))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; Takes two values and just expands into the first.
+(define-syntax match-drop-ids
+  (syntax-rules ()
+    ((_ expr ids ...) expr)))
+
+(define-syntax match-drop-first-arg
+  (syntax-rules ()
+    ((_ arg expr) expr)))
+
+;; To expand an OR group we try each clause in succession, passing the
+;; first that succeeds to the success continuation.  On failure for
+;; any clause, we just try the next clause, finally resorting to the
+;; failure continuation fk if all clauses fail.  The only trick is
+;; that we want to unify the identifiers, so that the success
+;; continuation can refer to a variable from any of the OR clauses.
+
+(define-syntax match-gen-or
+  (syntax-rules ()
+    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
+     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+  (syntax-rules ()
+    ((_ v () g+s sk fk . x)
+     ;; no OR clauses, call the failure continuation
+     fk)
+    ((_ v (p) . x)
+     ;; last (or only) OR clause, just expand normally
+     (match-one v p . x))
+    ((_ v (p . q) g+s sk fk i)
+     ;; match one and try the remaining on failure
+     (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
+    ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists.
+
+;; Look at the body of the simple case - it's just a named let loop,
+;; matching each element in turn to the same pattern.  The only trick
+;; is that we want to keep track of the lists of each extracted id, so
+;; when the loop recurses we cons the ids onto their respective list
+;; variables, and on success we bind the ids (what the user input and
+;; expects to see in the success body) to the reversed accumulated
+;; list IDs.
+
+(define-syntax match-gen-ellipses
+  (syntax-rules ()
+    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
+     (match-check-identifier p
+       ;; simplest case equivalent to (p ...), just bind the list
+       (let ((p v))
+         (if (list? p)
+             (sk ... i)
+             fk))
+       ;; simple case, match all elements of the list
+       (let loop ((ls v) (id-ls '()) ...)
+         (cond
+           ((null? ls)
+            (let ((id (reverse id-ls)) ...) (sk ... i)))
+           ((pair? ls)
+            (let ((w (car ls)))
+              (match-one w p ((car ls) (set-car! ls))
+                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+                         fk i)))
+           (else
+            fk)))))
+    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
+     ;; general case, trailing patterns to match, keep track of the
+     ;; remaining list length so we don't need any backtracking
+     (match-verify-no-ellipses
+      r
+      (let* ((tail-len (length 'r))
+             (ls v)
+             (len (length ls)))
+        (if (< len tail-len)
+            fk
+            (let loop ((ls ls) (n len) (id-ls '()) ...)
+              (cond
+                ((= n tail-len)
+                 (let ((id (reverse id-ls)) ...)
+                   (match-one ls r (#f #f) (sk ... i) fk i)))
+                ((pair? ls)
+                 (let ((w (car ls)))
+                   (match-one w p ((car ls) (set-car! ls))
+                              (match-drop-ids
+                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+                              fk
+                              i)))
+                (else
+                 fk)))))))))
+
+;; This is just a safety check.  Although unlike syntax-rules we allow
+;; trailing patterns after an ellipses, we explicitly disable multiple
+;; ellipses at the same level.  This is because in the general case
+;; such patterns are exponential in the number of ellipses, and we
+;; don't want to make it easy to construct very expensive operations
+;; with simple looking patterns.  For example, it would be O(n^2) for
+;; patterns like (a ... b ...) because we must consider every trailing
+;; element for every possible break for the leading "a ...".
+
+(define-syntax match-verify-no-ellipses
+  (syntax-rules ()
+    ((_ (x . y) sk)
+     (match-check-ellipse
+      x
+      (match-syntax-error
+       "multiple ellipse patterns not allowed at same level")
+      (match-verify-no-ellipses y sk)))
+    ((_ () sk)
+     sk)
+    ((_ x sk)
+     (match-syntax-error "dotted tail not allowed after ellipse" x))))
+
+;; Matching a tree search pattern is only slightly more complicated.
+;; Here we allow patterns of the form
+;;
+;;     (x *** y)
+;;
+;; to represent the pattern y located somewhere in a tree where the
+;; path from the current object to y can be seen as a list of the form
+;; (X ...).  Y can immediately match the current object in which case
+;; the path is the empty list.  In a sense it's a 2-dimensional
+;; version of the ... pattern.
+;;
+;; As a common case the pattern (_ *** y) can be used to search for Y
+;; anywhere in a tree, regardless of the path used.
+;;
+;; To implement the search, we use two recursive procedures.  TRY
+;; attempts to match Y once, and on success it calls the normal SK on
+;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
+;; call NEXT which first checks if the current value is a list
+;; beginning with X, then calls TRY on each remaining element of the
+;; list.  Since TRY will recursively call NEXT again on failure, this
+;; effects a full depth-first search.
+;;
+;; The failure continuation throughout is a jump to the next step in
+;; the tree search, initialized with the original failure continuation
+;; FK.
+
+(define-syntax match-gen-search
+  (syntax-rules ()
+    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
+     (letrec ((try (lambda (w fail id-ls ...)
+                     (match-one w q g+s
+                                (match-drop-ids
+                                 (let ((id (reverse id-ls)) ...)
+                                   sk))
+                                (next w fail id-ls ...) i)))
+              (next (lambda (w fail id-ls ...)
+                      (if (not (pair? w))
+                          (fail)
+                          (let ((u (car w)))
+                            (match-one
+                             u p ((car w) (set-car! w))
+                             (match-drop-ids
+                              ;; accumulate the head variables from
+                              ;; the p pattern, and loop over the tail
+                              (let ((id-ls (cons id id-ls)) ...)
+                                (let lp ((ls (cdr w)))
+                                  (if (pair? ls)
+                                      (try (car ls)
+                                           (lambda () (lp (cdr ls)))
+                                           id-ls ...)
+                                      (fail)))))
+                             (fail) i))))))
+       ;; the initial id-ls binding here is a dummy to get the right
+       ;; number of '()s
+       (let ((id-ls '()) ...)
+         (try v (lambda () fk) id-ls ...))))))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+  (syntax-rules (___)
+    ((_ v n pats (p q) . x)
+     (match-check-ellipse q
+                          (match-gen-vector-ellipses v n pats p . x)
+                          (match-vector-two v n pats (p q) . x)))
+    ((_ v n pats (p ___) sk fk i)
+     (match-gen-vector-ellipses v n pats p sk fk i))
+    ((_ . x)
+     (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) () sk fk i)
+     (if (vector? v)
+         (let ((len (vector-length v)))
+           (if (= len n)
+               (match-vector-step v ((pat index) ...) sk fk i)
+               fk))
+         fk))
+    ((_ v n (pats ...) (p . q) . x)
+     (match-vector v (+ n 1) (pats ... (p n)) q . x))))
+
+(define-syntax match-vector-step
+  (syntax-rules ()
+    ((_ v () (sk ...) fk i) (sk ... i))
+    ((_ v ((pat index) . rest) sk fk i)
+     (let ((w (vector-ref v index)))
+       (match-one w pat ((vector-ref v index) (vector-set! v index))
+                  (match-vector-step v rest sk fk)
+                  fk i)))))
+
+;; With a vector ellipse pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-gen-vector-ellipses
+  (syntax-rules ()
+    ((_ v n ((pat index) ...) p sk fk i)
+     (if (vector? v)
+       (let ((len (vector-length v)))
+         (if (>= len n)
+           (match-vector-step v ((pat index) ...)
+                              (match-vector-tail v p n len sk fk)
+                              fk i)
+           fk))
+       fk))))
+
+(define-syntax match-vector-tail
+  (syntax-rules ()
+    ((_ v p n len sk fk i)
+     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+  (syntax-rules ()
+    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+     (let loop ((j n) (id-ls '()) ...)
+       (if (>= j len)
+         (let ((id (reverse id-ls)) ...) (sk ... i))
+         (let ((w (vector-ref v j)))
+           (match-one w p ((vector-ref v j) (vetor-set! v j))
+                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+                      fk i)))))))
+
+;; Extract all identifiers in a pattern.  A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and non-pattern forms (such as the predicate expression in ?
+;; patterns), and also ignore previously bound identifiers.
+;;
+;; Calls the continuation with all new vars as a list of the form
+;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
+;; pair with the original variable (e.g. it's used in the ellipse
+;; generation for list variables).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+  (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
+    ((match-extract-vars (? pred . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars ($ rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (= proc p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (quote x) (k ...) i v)
+     (k ... v))
+    ((match-extract-vars (quasiquote x) k i v)
+     (match-extract-quasiquote-vars x k i v (#t)))
+    ((match-extract-vars (and . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (or . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (not . p) . x)
+     (match-extract-vars p . x))
+    ;; A non-keyword pair, expand the CAR with a continuation to
+    ;; expand the CDR.
+    ((match-extract-vars (p q . r) k i v)
+     (match-check-ellipse
+      q
+      (match-extract-vars (p . r) k i v)
+      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+    ((match-extract-vars (p . q) k i v)
+     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+    ((match-extract-vars #(p ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars _ (k ...) i v)    (k ... v))
+    ((match-extract-vars ___ (k ...) i v)  (k ... v))
+    ((match-extract-vars *** (k ...) i v)  (k ... v))
+    ;; This is the main part, the only place where we might add a new
+    ;; var if it's an unbound symbol.
+    ((match-extract-vars p (k ...) (i ...) v)
+     (let-syntax
+         ((new-sym?
+           (syntax-rules (i ...)
+             ((new-sym? p sk fk) sk)
+             ((new-sym? x sk fk) fk))))
+       (new-sym? random-sym-to-match
+                 (k ... ((p p-ls) . v))
+                 (k ... v))))
+    ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+  (syntax-rules ()
+    ((_ p k i v ((v2 v2-ls) ...))
+     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+    ))
+
+(define-syntax match-extract-quasiquote-vars
+  (syntax-rules (quasiquote unquote unquote-splicing)
+    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+     (match-extract-quasiquote-vars x k i v (#t . d)))
+    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+     (match-extract-quasiquote-vars (unquote x) k i v d))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+     (match-extract-vars x k i v))
+    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+     (match-extract-quasiquote-vars x k i v d))
+    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+     (match-extract-quasiquote-vars
+      x
+      (match-extract-quasiquote-vars-step y k i v d) i ()))
+    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+     (match-extract-quasiquote-vars (x ...) k i v d))
+    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+     (k ... v))
+    ))
+
+(define-syntax match-extract-quasiquote-vars-step
+  (syntax-rules ()
+    ((_ x k i v d ((v2 v2-ls) ...))
+     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+    ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+(define-syntax match-lambda
+  (syntax-rules ()
+    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+
+(define-syntax match-lambda*
+  (syntax-rules ()
+    ((_ clause ...) (lambda expr (match expr clause ...)))))
+
+(define-syntax match-let
+  (syntax-rules ()
+    ((_ (vars ...) . body)
+     (match-let/helper let () () (vars ...) . body))
+    ((_ loop . rest)
+     (match-named-let loop () . rest))))
+
+(define-syntax match-letrec
+  (syntax-rules ()
+    ((_ vars . body) (match-let/helper letrec () () vars . body))))
+
+(define-syntax match-let/helper
+  (syntax-rules ()
+    ((_ let ((var expr) ...) () () . body)
+     (let ((var expr) ...) . body))
+    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+     (let ((var expr) ...)
+       (match-let* ((pat tmp) ...)
+         . body)))
+    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+     (match-let/helper
+      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
+
+(define-syntax match-named-let
+  (syntax-rules ()
+    ((_ loop ((pat expr var) ...) () . body)
+     (let loop ((var expr) ...)
+       (match-let ((pat var) ...)
+         . body)))
+    ((_ loop (v ...) ((pat expr) . rest) . body)
+     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+(define-syntax match-let*
+  (syntax-rules ()
+    ((_ () . body)
+     (begin . body))
+    ((_ ((pat expr) . rest) . body)
+     (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Otherwise COND-EXPANDed bits.
+
+;; This *should* work, but doesn't :(
+;;   (define-syntax match-check-ellipse
+;;     (syntax-rules (...)
+;;       ((_ ... sk fk) sk)
+;;       ((_ x sk fk) fk)))
+
+;; This is a little more complicated, and introduces a new let-syntax,
+;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
+;; originally came up with the idea.
+(define-syntax match-check-ellipse
+  (syntax-rules ()
+    ;; these two aren't necessary but provide fast-case failures
+    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
+    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
+    ;; matching an atom
+    ((match-check-ellipse id success-k failure-k)
+     (let-syntax ((ellipse? (syntax-rules ()
+                              ;; iff `id' is `...' here then this will
+                              ;; match a list of any length
+                              ((ellipse? (foo id) sk fk) sk)
+                              ((ellipse? other sk fk) fk))))
+       ;; this list of three elements will only many the (foo id) list
+       ;; above if `id' is `...'
+       (ellipse? (a b c) success-k failure-k)))))
+
+
+;; This is portable but can be more efficient with non-portable
+;; extensions.  This trick was originally discovered by Oleg Kiselyov.
+
+(define-syntax match-check-identifier
+  (syntax-rules ()
+    ;; fast-case failures, lists and vectors are not identifiers
+    ((_ (x . y) success-k failure-k) failure-k)
+    ((_ #(x ...) success-k failure-k) failure-k)
+    ;; x is an atom
+    ((_ x success-k failure-k)
+     (let-syntax
+         ((sym?
+           (syntax-rules ()
+             ;; if the symbol `abracadabra' matches x, then x is a
+             ;; symbol
+             ((sym? x sk fk) sk)
+             ;; otherwise x is a non-symbol datum
+             ((sym? y sk fk) fk))))
+       (sym? abracadabra success-k failure-k)))))

Re: fmatch

[Ludovic Courtès]

Hi Stefan!

Sorry for the late late reply.

stefan <stefan.tampe@spray.se> writes:

> Anyway git diff --cached  gives the attached patch file.
>
> Also I made the code less hacky by using define-syntax in stead
> of a defmacro and macroexpand for the defin-syntax sugar (oh hacker). 
> It was a litle more work then I expected.

OK.  I just applied the patch and looked at ice-9/match.scm.

To start with, I committed the unmodified pattern matcher by Shinn, a
simple (ice-9 match) that just includes it, and a small set of tests.

The next step will be to integrate your work in match.upstream.scm (sic)
and discuss it with Shinn.

Thanks,
Ludo'.

Re: fmatch

[stefan]

On Wednesday 16 June 2010 11:31:14 pm Ludovic Courtès wrote:
> Hi Stefan!
> 
> Sorry for the late late reply.
> 
> stefan <stefan.tampe@spray.se> writes:
> > Anyway git diff --cached  gives the attached patch file.
> >
> > Also I made the code less hacky by using define-syntax in stead
> > of a defmacro and macroexpand for the defin-syntax sugar (oh hacker).
> > It was a litle more work then I expected.
> 
> OK.  I just applied the patch and looked at ice-9/match.scm.
> 
> To start with, I committed the unmodified pattern matcher by Shinn, a
> simple (ice-9 match) that just includes it, and a small set of tests.
> 
> The next step will be to integrate your work in match.upstream.scm (sic)
> and discuss it with Shinn.
> 
> Thanks,
> Ludo'.

Cool!

I think that the match-define logic is something that is missing in the 
Shinn version although I don't know how much this construct is used.

For the $ destruction I would be very careful, as you know from the irc 
discussion. So for all to be able to participate here is a short 
description of the problem with $.

Basically $ is using the order of the records like ($ person? Rec1 Rec2 , ... 
Recn)
and is nice to do quick hacks and get dense informative matchers. On the 
other hand if the record specification changes, like the order of the 
records or meanings etc havoc can enter. So destructuring on order would 
probably, in the end, yield a buggy code base. And I suspect that this issue 
makes the $ construct less liked and probably will not be accepted upstreams.

On the other hand we have the record-case construct that is somewhat dense in 
information but is not hygienic. That would leave us with constructs like

(and (= person-height pat1)
     (= person-weight pat2)
     ...)

We can streamline it a little but the end win is marginal compared to the 
size of usual accessor names.

I would have liked something like
($ person (height pat1) (weight pat2))

But again this is not hygienic!

What do you think?

Regards
Stefan

Re: fmatch

[Ludovic Courtès]

Hi!

stefan <stefan.tampe@spray.se> writes:

> I think that the match-define logic is something that is missing in the 
> Shinn version although I don't know how much this construct is used.

Yes, I left a comment about it in ice-9/match.scm.

> Basically $ is using the order of the records like ($ person? Rec1 Rec2 , ... 
> Recn)
> and is nice to do quick hacks and get dense informative matchers. On the 
> other hand if the record specification changes, like the order of the 
> records or meanings etc havoc can enter. So destructuring on order would 
> probably, in the end, yield a buggy code base. And I suspect that this issue 
> makes the $ construct less liked and probably will not be accepted upstreams.
>
> On the other hand we have the record-case construct that is somewhat dense in 
> information but is not hygienic. That would leave us with constructs like
>
> (and (= person-height pat1)
>      (= person-weight pat2)
>      ...)
>
> We can streamline it a little but the end win is marginal compared to the 
> size of usual accessor names.

It looks like we are somewhere between a rock and a hard place.  :-)

> I would have liked something like
> ($ person (height pat1) (weight pat2))

Perhaps:

  ($ person? (person-height h) (person-weight w))

But then again, if we look at, say, language/tree-il/analyze.scm as an
example, it seems clear that such a syntax would be too heavyweight.

In Coq, OCaml, Scala, etc., one matches on the type constructor:

  match stefan with
    | Person h w => ...
  end

This *is* also positional matching, except that it relates to the
position of the arguments to the constructor, not to the position of
slots within the structure.  In the end, it’s not too different, though.

So, I’m still in favor of adding Wright’s ‘$’ positional pattern
matching, along with ‘=’ to match with named accessors.

Thanks,
Ludo’.