pass at srfi-89 implementation

pass at srfi-89 implementation

[Julian Graham]

[-- Attachment #1: Type: text/plain, Size: 2047 bytes --]

Hi everyone,

So I've taken a stab at implementing SRFI-89, using Guile's existing
(ice-9 optargs) module -- my thinking was that the two were similar
enough to make it worthwhile to have optargs do most of the heavy
lifting.  What I've done is add some pre-parsing of the formals list
before it's passed to (ice-9 optargs)'s lambda* and some accommodation
of incompatible behavior.  Specifically:

* The (ice-9 optargs) module requires that the #optionals section, if
present, come before the #keywords section, whereas SRFI-89 allows its
corresponding sections to be in either order.

* (ice-9 optargs) requires that non-optional positional formals be
specified before any optional positional or keyword formals.

* (ice-9 optargs) (and, apparently, Common Lisp) adds all the keyword
arguments to the rest argument at call time.

* SRFI-89 doesn't allow duplicate keyword arguments in a function call.

* SRFI-89 keyword definitions allow the value of a keyword argument to
be bound to a variable with a different name than the keyword; (ice-9
optargs) does not.

I think that's everything -- except for one last quirk of (ice-9
optargs) that I discovered last night and am having trouble working
around.  It looks like when you've defined a function that takes
traditional/required as well as keyword arguments, you need to pass
all of the required arguments before passing any of the keyword ones.
For example:

(define* (g a #:key (b #f) #:rest r) (list a b r))

(g 1 #:b 2 3) => (1 2 (3))

...but

(g #:b 2 1 3) => (#:b #f (2 1 3))

The docs sort of hint at why this is implemented the way it is, but I
think it eliminates a lot of the flexibility that keyword arguments
buy you in the first place.  What I want to know is whether this seems
to you like a shortcoming in (ice-9 optargs) that ought to be fixed,
or whether I should just ditch my implementation and go with the
vanilla SRFI-89 implementation included with the specification.

I've attached the draft I've been working on in case anyone wants to
have a look.


Regards,
Julian

[-- Attachment #2: srfi-89.scm --]
[-- Type: application/octet-stream, Size: 3657 bytes --]

;;; srfi-89.scm --- Optional positional and named parameters

;; Copyright (C) 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 2.1 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 (srfi srfi-89)
  #:use-module (ice-9 optargs)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-88)
  #:replace (define* lambda*))

(define-macro (define* pattern . body)
  (if (pair? pattern)
      `(define ,(car pattern) (lambda* ,(cdr pattern) ,@body))
      `(define ,pattern ,@body)))

(define-macro (lambda* formals . body)
  (define (transform-formals lst ht)
    (define (transform-pairs lst)
      (define (format-lists named optional)
	(append '() 
		(if (null? optional) '() (cons #:optional optional))
		(if (null? named) '() (cons #:key named))))
      (define (car-is-keyword? x) (keyword? (car x)))
      (define (not-car-is-keyword? x) (not (car-is-keyword? x)))
      (define (save-binding x)
	(let ((cx (string->symbol (keyword->string (car x)))))
	  (hashq-set! ht cx (cadr x)) 
	  (cons cx (cddr x))))
      (define (parse-formals lst keywords-first)
	(receive (l1 l2)
		 ((if keywords-first span break) car-is-keyword? lst)
		 (if (or (find car-is-keyword? (if keywords-first l2 l1))
			 (find not-car-is-keyword? (if keywords-first l1 l2)))
		     (error "Ordering error in formal parameters list")
		     (format-lists (map save-binding (if keywords-first l1 l2))
				   (if keywords-first l2 l1)))))
	
      (if (null? lst) '() (parse-formals lst (car-is-keyword? (car lst)))))
  
    (receive (other-formals req-positionals)
	     (partition pair? lst)
	     (append req-positionals (transform-pairs other-formals))))

  (define (formals+rest l)
    (define (inner h t)
      (if (pair? t) (inner (append h (list (car t))) (cdr t)) (values h t)))
    (inner '() l))

  (receive 
   (n-r r)
   (formals+rest formals)  
   (let* ((ht (make-hash-table))
	  (rest (if (not (null? r)) r 'srfi-89:rest-var))
	  (tf (append (transform-formals n-r ht) (list #:rest rest)))	  
	  (kws (hash-map->list cons ht)))
     
     `(let ((receive (@ (srfi srfi-8) receive))

	    (let-keywords* (@ (ice-9 optargs) let-keywords*))
	    (let-optional* (@ (ice-9 optargs) let-optional*)))
	((@ (ice-9 optargs) lambda*) ,tf

	 (define (srfi-89:rest r)
	   (define count (@ (srfi srfi-1) count))
	   (define delete-duplicates (@ (srfi srfi-1) delete-duplicates))
	   (define split-at (@ (srfi srfi-1) split-at))
	   
	   (receive (ks rs)
		    (split-at r (* (count keyword? r) 2))
		    (let ((kws (filter keyword? ks)))
		      (if (eq? kws (delete-duplicates kws))
			  rs (error "Duplicate keyword binding")))))
	 
	 ,(if (not (null? r))
	       `(receive
		 ,(append (map cdr kws) `(,rest))
		 ,(cons 'values (append (map car kws) `((srfi-89:rest ,rest))))
		 ,@body)
	       `(receive ,(map cdr kws)
			 ,(cons 'values (map car kws))
			 (begin (or (null? (srfi-89:rest ,rest))
				    (error "Wrong number of argument"))
				,@body))))))))

[-- Attachment #3: srfi-89.test --]
[-- Type: application/octet-stream, Size: 2520 bytes --]

;;;; srfi-89.test --- Test suite for SRFI-89              -*- Scheme -*-
;;;; Julian Graham <julian.graham@aya.yale.edu>
;;;;
;;;; 	Copyright (C) 2008 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-srfi-89)
  :use-module (test-suite lib)
  :use-module (srfi srfi-89))

\f
;; These are all taken from SRFI-89.

(define* (f a (b #f)) (list a b))
(define* (g a (b a) (key: k (* a b))) (list a b k))
(define* (h1 a (key: k #f) . r) (list a k r))
(define* (h2 (key: k #f) a . r) (list a k r))

(with-test-prefix "srfi-89"

  (pass-if "default-values-1" (equal? (f 1) '(1 #f)))
  (pass-if "default-values-2" (equal? (f 1 2) '(1 2)))
  (pass-if "argument-count-1" (not (false-if-exception (f 1 2 3))))

  (pass-if "default-values-3" (equal? (g 3) '(3 3 9)))
  (pass-if "default-values-4" (equal? (g 3 4) '(3 4 12)))
  (pass-if "malformed-keyword" (not (false-if-exception (g 3 4 key:))))
  (pass-if "keyword-1" (equal? (g 3 4 key: 5) '(3 4 5)))
  (pass-if "undefined-keyword" (not (false-if-exception (g 3 4 zoo: 5))))
  (pass-if "duplicate-keyword" 
    (not (false-if-exception (g 3 4 key: 5 key: 6))))

  (pass-if "keywords-and-rest-1" (equal? (h1 7) '(7 #f ())))
  (pass-if "keywords-and-rest-2" (equal? (h1 7 8 9 10) '(7 #f (8 9 10))))
  (pass-if "keywords-and-rest-3" (equal? (h1 7 key: 8 9 10) '(7 8 (9 10))))
  (pass-if "undefined-keyword-2" 
    (not (false-if-exception (h1 7 key: 8 zoo: 9))))
  
  (pass-if "required-positionals-1" (equal? (h2 7) '(7 #f ())))
  (pass-if "required-positionals-2" (equal? (h2 7 8 9 10) '(7 #f (8 9 10))))
  (pass-if "required-positionals-3" (equal? (h2 key: 8 9 10) '(9 8 (10))))
  (pass-if "undefined-keyword-3" 
    (not (false-if-exception (h2 key: 8 zoo: 9) ))))

;;; Local Variables:
;;; coding: latin-1
;;; End:

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> So I've taken a stab at implementing SRFI-89

This is good news!

Neil and I have agreed to release 1.8.5 ASAP, which I'll try to do by
the end of the week, after which I'll look into your SRFI-89 module if
no one beats me at it.  ;-)

Thanks,
Ludovic.

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> So I've taken a stab at implementing SRFI-89, using Guile's existing
> (ice-9 optargs) module -- my thinking was that the two were similar
> enough to make it worthwhile to have optargs do most of the heavy
> lifting.  What I've done is add some pre-parsing of the formals list
> before it's passed to (ice-9 optargs)'s lambda* and some accommodation
> of incompatible behavior.  Specifically:

Would it be a lot more time to make SRFI-89 independent of `(ice-9
optargs)' given the differences you describe?

IMO it would look cleaner and be more robust in the face of changes in
`(ice-9 optargs)'.  It would also make sure the SRFI-89 implementation
is not subtly biased towards what's in `(ice-9 optargs)'.

What do you think?

Ludovic.

Re: pass at srfi-89 implementation

[Julian Graham]

Well, there's a reference implementation of SRFI-89 that (I think)
could just be dropped in and used, now that we have SRFI-88-style
keywords.  I was just hoping that the existence of `(ice-9 optargs)'
would make possible a more compact / potentially more efficient
implementation.


> Would it be a lot more time to make SRFI-89 independent of `(ice-9
> optargs)' given the differences you describe?
>
> IMO it would look cleaner and be more robust in the face of changes in
> `(ice-9 optargs)'.  It would also make sure the SRFI-89 implementation
> is not subtly biased towards what's in `(ice-9 optargs)'.
>
> What do you think?

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi,

"Julian Graham" <joolean@gmail.com> writes:

> Well, there's a reference implementation of SRFI-89 that (I think)
> could just be dropped in and used, now that we have SRFI-88-style
> keywords.

It looks like the license terms would indeed allow us to do that.  I'm
not sure whether there's a precedent including non-LGPL SRFI code as is,
though.

Besides, we'd have to check whether the reference implementation, which
targets Gambit's compiler, is suitable for Guile.

Thoughts?

> I was just hoping that the existence of `(ice-9 optargs)'
> would make possible a more compact / potentially more efficient
> implementation.

Yes, it also stroke me as a worthy goal at first, but the differences
you listed led me to think we might be better off with a separate
implementation.

Thanks, and sorry for the hassle!

Ludovic.

Re: pass at srfi-89 implementation

[Julian Graham]

> It looks like the license terms would indeed allow us to do that.  I'm
> not sure whether there's a precedent including non-LGPL SRFI code as is,
> though.

Well, it wouldn't have to be 100% as-is -- aside from adding the
module declaration, there are some things I wouldn't mind tweaking a
bit, such as where the argument-parsing helper functions get declared
/ exported.


> Besides, we'd have to check whether the reference implementation, which
> targets Gambit's compiler, is suitable for Guile.

Having done a very quick and dirty integration, I can say that it
passes the rudimentary test suite I pulled from the SRFI document.  In
terms of whether it's suitable... well, Marc claims his implementation
isn't even suitable for Gambit, which apparently has a native
implementation:

"To give a rough idea of the speed improvement, a trivial procedure
with 10 optional named parameters and called with 5 named parameters
runs 14 times faster and generates no garbage when the Gambit
compiler's builtin optional parameter passing mechanism is used."

I haven't benchmarked it against `(ice-9 optargs)', but it seems like
our options are: Use the reference implementation, optimizing it as
best we can for the peculiarities of Guile; write our own
implementation in Scheme or C that would exist in parallel with
`(ice-9 optargs)'; or enhance `(ice-9 optargs)' to allow a dependent
implementation such as the one I submitted to work correctly.

What do you think?


Regards,
Julian

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi,

"Julian Graham" <joolean@gmail.com> writes:

> Having done a very quick and dirty integration, I can say that it
> passes the rudimentary test suite I pulled from the SRFI document.  In
> terms of whether it's suitable... well, Marc claims his implementation
> isn't even suitable for Gambit, which apparently has a native
> implementation:
>
> "To give a rough idea of the speed improvement, a trivial procedure
> with 10 optional named parameters and called with 5 named parameters
> runs 14 times faster and generates no garbage when the Gambit
> compiler's builtin optional parameter passing mechanism is used."

Ouch!

> I haven't benchmarked it against `(ice-9 optargs)', but it seems like
> our options are: Use the reference implementation, optimizing it as
> best we can for the peculiarities of Guile; write our own
> implementation in Scheme or C that would exist in parallel with
> `(ice-9 optargs)'; or enhance `(ice-9 optargs)' to allow a dependent
> implementation such as the one I submitted to work correctly.
>
> What do you think?

I'm still not convinced by the last option.  Given the above, Option 2
(that is, writing our own, preferably in Scheme) seems to be the safest.
Hopefully this isn't too much work, but the above quote indicates that
we should be careful about performance.  ;-)

Would you like to try doing it?

Thanks,
Ludovic.

Re: pass at srfi-89 implementation

[Julian Graham]

> I'm still not convinced by the last option.  Given the above, Option 2
> (that is, writing our own, preferably in Scheme) seems to be the safest.
> Hopefully this isn't too much work, but the above quote indicates that
> we should be careful about performance.  ;-)
>
> Would you like to try doing it?

[Time passes.]

Okay, I've tried -- at length.  And so far I haven't been able to top
the performance of the reference implementation.  In fact, it actually
seems to be fairly efficient (I now think Marc's quote above about
Gambit's built-in support says less about the relative shortcomings of
his particular implementation and more about the benefits of doing
something like this in native code).  From what I can see, there are
only a few areas in which the reference implementation could be
improved by Guile-specific features:

* Native hash tables (Marc's code has its own hash table implementation)
   * Use of `hashq-get-handle' (the reference implementation relies on
the identity of an `undefined' object)
* Symbol generation for naming run-time helper functions (the
reference implementation explicitly exports bindings for helper
functions)

So it looks like the right way to go might be to tweak Marc's
implementation so that it takes advantage of the above, although I
don't see it improving the performance all that much.  Alternatively,
we could do this in C, but I don't know if it's worth the added
complexity.  Thoughts?


Regards,
Julian

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi Julian,

"Julian Graham" <joolean@gmail.com> writes:

> Okay, I've tried -- at length.  And so far I haven't been able to top
> the performance of the reference implementation.  In fact, it actually
> seems to be fairly efficient

Did you run some sort of "benchmark"?

> From what I can see, there are
> only a few areas in which the reference implementation could be
> improved by Guile-specific features:
>
> * Native hash tables (Marc's code has its own hash table implementation)
>    * Use of `hashq-get-handle' (the reference implementation relies on
> the identity of an `undefined' object)

The reference implementation strives to create a perfect hash table,
while Guile's built-in hash tables may not be perfect all the time
(there can be collisions, although tables are automatically resized once
in a while).  So, theoretically, the reference implementation's solution
is more efficient.

OTOH, as is often the case with Guile, it may turn out to be faster to
use Guile's built-in hash tables, especially since they may end up being
"perfect" (i.e., collision-free) in most cases here; in addition,
running one `make-perfect-hash-table' for each `lambda*' at
initialization time may turn out to be more costly than just
`make-hash-table'.  Could you try that out?

> * Symbol generation for naming run-time helper functions (the
> reference implementation explicitly exports bindings for helper
> functions)

Hmm, what are you referring to precisely?

Also:

 * use Guile's `string-hash' in `$hash-keyword' (unless Guile's hash
   tables are used, that is).

Overall, it may indeed be wise to use the reference implementation.
However, we'd need a copyright assignment from Marc and/or licensing
under LGPLv2+.

Thanks,
Ludovic.

Re: pass at srfi-89 implementation

[Julian Graham]

(Sorry for the late reply -- I was out of the country last week...)

>> Okay, I've tried -- at length.  And so far I haven't been able to top
>> the performance of the reference implementation.  In fact, it actually
>> seems to be fairly efficient
>
> Did you run some sort of "benchmark"?

Yes.  Nothing formal, though -- I pretty much just defined a number of
different SRFI-89-style functions with different signatures (optional
arguments, keyword arguments, optional and keyword arguments) and used
`(gettimeofday)' to see how long it took to run them in a loop a few
hundred thousand times.  On average, my implementation still takes
about 70% longer than Marc's, which is pretty embarrassing, but I'm
still attempting to profile and optimize it (at the moment it looks
like most of the time is spent in an initial sorting pass).

(Has anyone else noticed that statprof hasn't been working for a while
now?  I get a "Numerical overflow" from `statprof-display' no matter
what arguments I pass to `statprof-reset'.)


> The reference implementation strives to create a perfect hash table,
> while Guile's built-in hash tables may not be perfect all the time
> (there can be collisions, although tables are automatically resized once
> in a while).  So, theoretically, the reference implementation's solution
> is more efficient.
>
> OTOH, as is often the case with Guile, it may turn out to be faster to
> use Guile's built-in hash tables, especially since they may end up being
> "perfect" (i.e., collision-free) in most cases here; in addition,
> running one `make-perfect-hash-table' for each `lambda*' at
> initialization time may turn out to be more costly than just
> `make-hash-table'.  Could you try that out?

Yeah, I'm already using Guile's hash tables and creating the table
with a big enough initial size to store all of the keywords specified
in the argument list -- and since Guile's hash tables are native, my
(naive) assumption is that they're probably as fast or faster than a
pure-Scheme perfect hashing system.  But I could try perfect hashing.


>> * Symbol generation for naming run-time helper functions (the
>> reference implementation explicitly exports bindings for helper
>> functions)
>
> Hmm, what are you referring to precisely?

Well, like Marc's version, my code requires a few named procedures at
runtime to handle things like argument processing (see `$process-args'
in the reference implementation) buts needs to avoid collisions
between these bindings and bindings in user code.  I'm assuming this
was Marc's intent in naming his helper procedures with $-signs and
binding them in the top-level environment -- i.e. that he made it
obvious which names users need to avoid.  But Guile's `gensym' allows
for the creation of local (to the lambda* expression) bindings that
are guaranteed not to shadow anything in the user's environment.


> Overall, it may indeed be wise to use the reference implementation.
> However, we'd need a copyright assignment from Marc and/or licensing
> under LGPLv2+.

Yeah.  My approach thus far has been to do this as a "clean room"
implementation based only on the SRFI-89 spec, and it goes without
saying that Marc understands this SRFI more intimately than I do.
Maybe let me hack on it a bit longer and report back, though?


Regards,
Julian

Re: pass at srfi-89 implementation

[Andy Wingo]

Hi Julian,

On Sat 16 Aug 2008 14:19, "Julian Graham" <joolean@gmail.com> writes:

> (Has anyone else noticed that statprof hasn't been working for a while
> now?  I get a "Numerical overflow" from `statprof-display' no matter
> what arguments I pass to `statprof-reset'.)

I haven't noticed this, no. Normally this would mean that we're dividing
by zero, perhaps no counts were taken or something. (Perhaps we should
pull statprof into guile itself.) Let me know if you get around to
fixing this before I do.

Andy
-- 
http://wingolog.org/

Re: pass at srfi-89 implementation

[Ludovic Courtès]

Hi,

Andy Wingo <wingo@pobox.com> writes:

> I haven't noticed this, no. Normally this would mean that we're dividing
> by zero, perhaps no counts were taken or something. (Perhaps we should
> pull statprof into guile itself.) Let me know if you get around to
> fixing this before I do.

It could be that your program didn't spend enough time in user space,
too.

Speaking of which: Andy, did you see this discussion?

  http://thread.gmane.org/gmane.lisp.guile.bugs/3895

I'm concerned about the accuracy of `statprof' given that handlers are
called asynchronously.

Thanks,
Ludovic.

Re: pass at srfi-89 implementation

[Andy Wingo]

Hi,

On Wed 20 Aug 2008 00:32, ludo@gnu.org (Ludovic Courtès) writes:

>   http://thread.gmane.org/gmane.lisp.guile.bugs/3895
>
> I'm concerned about the accuracy of `statprof' given that handlers are
> called asynchronously.

Signal handlers have always been called asynchronously, so there's been
some fuzziness as to when statprof handlers get called; in practice
however it's corresponded pretty well.

I just ran the statprof unit test and it seems to still be OK. Perhaps
in Julien's run, there simply was not enough time in user space relative
to the sampling frequency. (Certainly statprof should deal with this in
a more intelligent fashion.)

Andy
-- 
http://wingolog.org/

Re: pass at srfi-89 implementation

[Julian Graham]

> I just ran the statprof unit test and it seems to still be OK. Perhaps
> in Julien's run, there simply was not enough time in user space relative
> to the sampling frequency. (Certainly statprof should deal with this in
> a more intelligent fashion.)

That's certainly possible (I take it you're using "user space" to mean
"non-primitive function code"), although I know it's collecting some
samples at least because I've added `display' calls to statprof
itself.  One thing I just noticed is that the whole profiling process
seems to work fine if count-calls? is false -- is that part of the
unit test?

On a more general note, it would be great if statprof were more robust
/ could profile more and different types of code.  When you say "pull
statprof into guile itself," Andy, do you mean getting profiling
functionality into libguile or just including the module in the core
distribution?  (The former would be pretty sweet...)


Regards,
Julian

Re: pass at srfi-89 implementation

[Julian Graham]

[-- Attachment #1: Type: text/plain, Size: 911 bytes --]

Alright, I give up.  I'm still not exactly sure why my implementation
is as slow as it is; I have a hunch that I'm taking too long
processing the list of actual parameters, but I haven't been able to
glean many specifics from statprof.  Marc also employs some nifty but
un-Scheme-y (to my mind, at least) tricks that give his version an
edge, like emitting code that destructively modifies the argument list
as part of determining where to insert default values.

At any rate, find my version attached.  I think it's probably a dead
end in terms of going forward, but maybe it's salvageable by a more
experienced Schemer? ...Or maybe a more experienced Schemer could make
another attempt at doing an implementation from scratch?  I don't know
what the right course is -- I think it would probably be easy to do
something performant in C, but I also grok why that's not the
preferred solution.


Regards,
Julian

[-- Attachment #2: srfi-89.scm --]
[-- Type: application/octet-stream, Size: 6945 bytes --]

(define-module (srfi srfi-89)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-88)
  #:export (
	    define* 
	    lambda*))

(cond-expand-provide (current-module) '(srfi-89))

(define-macro (define* pattern . body)
  (if (pair? pattern)
      `(define ,(car pattern) (lambda* ,(cdr pattern) ,@body))
      `(define ,pattern ,@body)))

(define variable? symbol?)
(define required? variable?)
(define (optional? x) 
  (and (proper-list? x) (= (length x) 2) (variable? (car x))))
(define (positional? x) (or (required? x) (optional? x)))
(define (named? x)
  (and (proper-list? x) 
       (= (length x) 3) 
       (keyword? (car x)) 
       (variable? (cadr x))))

(define-macro (lambda* formals . body)
  ;; Because Guile's SRFI-1 doesn't work on dotted lists
  
  (define (length-permissive lst)
    (if (null? lst) 
	0
	(let ((clst (cdr lst)))
	  (if (pair? clst) (+ (length-permissive clst) 1) 2))))

  (define (span-permissive pred lst)
    (define (span-permissive-inner head tail)
      (if (or (null? tail) (not (pair? tail)))
	  (values head tail)
	  (let ((ctail (car tail)))
	    (if (pred ctail) 
		(span-permissive-inner (append head (list ctail)) (cdr tail))
		(values head tail)))))
    (span-permissive-inner '() lst))

  (define (emit required optional named rest named-first?)
    (define (emit-positional reqv optv loptv nmdv rstv)
      (define (emit-positional-tail)
	(if (or named-first? (null? named)) 
	    (emit-rest rstv) 
	    (emit-named reqv optv loptv nmdv rstv)))
      (append 
       (fold (lambda (x c) (append c `((,x (vector-ref ,reqv ,(length c))))))
	     '()
	     required)
       (if (null? optional)	   
	   (emit-positional-tail)
	   (let ((len (gensym))
		 (p (gensym)))
	     (append
	      (fold (lambda (x c)
		      (append c `((,x (if (> ,loptv ,(length c))
					  (vector-ref ,optv ,(length c))
					  ,(list-ref (map cadr optional)
						     (length c)))))))
		    '()
		    (map car optional))
	      (emit-positional-tail))))))
    (define (emit-named reqv optv loptv nmdv rstv)
      (define (emit-named-tail)
	(if named-first?
	    (emit-positional reqv optv loptv nmdv rstv)
	    (emit-rest rstv)))
      (if (null? named)
	  (emit-named-tail)
	  (let ((handle-var (gensym)))
	    (append 
	     (fold (lambda (x c)
		     (append c
			     `((,(cadr x) 
				(let ((,handle-var (hashq-get-handle 
						    ,nmdv ,(car x))))
				  (if ,handle-var
				      (cdr ,handle-var)
				      ,(caddr x)))))))
		   '()
		   named)
	     (emit-named-tail)))))
    (define (emit-rest rstv) (if rest `((,rest ,rstv)) '()))
    (let* ((srfi-89:bound-required-var (gensym))
	   (srfi-89:bound-optional-var (gensym))
	   (srfi-89:bound-required-counter (gensym))
	   (srfi-89:bound-optional-counter (gensym))
	   (srfi-89:bound-named-var (gensym))
	   (srfi-89:bound-rest-var (gensym))
	   
	   (srfi-89:process-args (gensym))

	   (srfi-89:num-required (length required))
	   (srfi-89:num-optional (length optional)))
      
      `(lambda srfi-89:args
	 (let ,srfi-89:process-args
	   ((,srfi-89:bound-required-var 
	     ,(if (null? required) #f `(make-vector ,srfi-89:num-required)))
	    (,srfi-89:bound-optional-var
	     ,(if (null? required) #f `(make-vector ,srfi-89:num-required)))
	    (,srfi-89:bound-required-counter 0)
	    (,srfi-89:bound-optional-counter 0)
	    (,srfi-89:bound-named-var 
	     ,(if (null? named) #f `(make-hash-table)))
	    (,srfi-89:bound-rest-var '())
	    (lst srfi-89:args))
	   (if (null? lst)
	       (begin 
		 (let* ,(if named-first?
			    (emit-named srfi-89:bound-required-var
					srfi-89:bound-optional-var
					srfi-89:bound-optional-counter
					srfi-89:bound-named-var
					srfi-89:bound-rest-var)
			    (emit-positional srfi-89:bound-required-var
					     srfi-89:bound-optional-var
					     srfi-89:bound-optional-counter
					     srfi-89:bound-named-var
					     srfi-89:bound-rest-var))
		   ,@body))
	       (let ((cl (car lst)))
		 (cond ,(if (not (null? named))
			    `((keyword? cl) 
			      (if (not (memq cl (quote ,(map car named))))
				  (error "unknown parameter keyword" cl))
			      (if (hashq-get-handle ,srfi-89:bound-named-var 
						    cl)
				  (error "duplicate parameter" cl))
			      (hashq-set! ,srfi-89:bound-named-var 
					  cl (cadr lst))
			      (,srfi-89:process-args
			       ,srfi-89:bound-required-var
			       ,srfi-89:bound-optional-var
			       ,srfi-89:bound-required-counter
			       ,srfi-89:bound-optional-counter
			       ,srfi-89:bound-named-var
			       ,srfi-89:bound-rest-var
			       (cddr lst)))
			    `(#f))
		       ((< ,srfi-89:bound-required-counter 
			   ,srfi-89:num-required)
			(vector-set! ,srfi-89:bound-required-var
				     ,srfi-89:bound-required-counter 
				     cl)
			(,srfi-89:process-args
			 ,srfi-89:bound-required-var
			 ,srfi-89:bound-optional-var
			 (+ ,srfi-89:bound-required-counter 1)
			 ,srfi-89:bound-optional-counter
			 ,srfi-89:bound-named-var
			 ,srfi-89:bound-rest-var
			 (cdr lst)))
		       ((< ,srfi-89:bound-optional-counter
			   ,srfi-89:num-optional)
			(vector-set! ,srfi-89:bound-optional-var
				     ,srfi-89:bound-optional-counter
				     cl)
			(,srfi-89:process-args
			 ,srfi-89:bound-required-var
			 ,srfi-89:bound-optional-var
			 ,srfi-89:bound-required-counter
			 (+ ,srfi-89:bound-optional-counter 1)
			 ,srfi-89:bound-named-var
			 ,srfi-89:bound-rest-var
			 (cdr lst)))
		       ((quote ,rest) (,srfi-89:process-args
				       ,srfi-89:bound-required-var
				       ,srfi-89:bound-optional-var
				       ,srfi-89:bound-required-counter
				       ,srfi-89:bound-optional-counter
				       ,srfi-89:bound-named-var
				       lst
				       '()))
		       (else (error "too many actual parameters")))))))))
	 
  (define (parse-1 positional named rest named-first?)
    (receive (required optional)
	     (span-permissive required? positional)
	     (emit required optional named rest named-first?)))

  (cond ((null? formals) `(lambda () ,@body))
	((variable? formals) `(lambda ,formals ,@body))
	((positional? (car formals))
	 (receive (positional named) 
		  (span-permissive positional? formals)
		  (cond ((and (not (symbol? named)) (dotted-list? named))
			 (receive (named rest)
				  (split-at named
					    (- (length-permissive named) 1))
				  (parse-1 positional named rest #f)))
			((list? named) (parse-1 positional named #f #f))
			(else (parse-1 positional '() named #f)))))
	((named? (car formals))
	 (receive (named positional)
		  (span-permissive named? formals)
		  (cond ((and (not (symbol? positional))
			      (dotted-list? positional))
			 (receive (positional rest)
				  (split-at positional 
					    (- (length-permissive positional) 
					       1))
				  (parse-1 positional named rest #t)))
			((list? positional) (parse-1 positional named #f #t))
			(else (parse-1 '() named positional #t)))))
	(else (error "Error in formal parameter list"))))