Re: pass at srfi-89 implementation

["Julian Graham" <joolean@gmail.com>]

[-- 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"))))