syntax-rules implementation on explicit renaming. still in work

sr->er.scm

(import (scheme base))
(import (scheme cxr))
(import (picrin macro))
(import (scheme write))

;;; utility functions
(define (reverse* l)
  ;; (reverse* '(a b c d . e)) => (e d c b . a)
  (let loop ((r (car l))
	     (l (cdr l)))
    (if (pair? l)
	(loop (cons (car l) r) (cdr l))
	(cons l r))))

(define (number->string n)
  (case n
    ((0) "0")
    ((1) "1")
    ((2) "2")
    ((3) "3")
    (else "hogee")))

(define (var->sym v)
  (let loop ((cnt 0)
	     (v v))
    (if (symbol? v)
	(string->symbol (string-append (symbol->string v) "/" (number->string cnt)))
	(loop (+ 1 cnt) (car v)))))

;; (push-var '((v))) => '(((v)))
(define push-var list)

(define (every? pred l)
  (if (null? l)
      #t
      (and (pred (car l)) (every? pred (cdr l)))))

(define (flatten l)
  (cond
   ((null? l) '())
   ((pair? (car l))
    (append (flatten (car l)) (flatten (cdr l))))
   (else
    (cons (car l) (flatten (cdr l))))))

;;; compile match
(define (compile-match ellipsis literals pattern)
  (letrec ((compile-match-base
	    (lambda (pattern)
	      (cond ((eq? pattern '_) (values #f '()))
		    ((member pattern literals)
		     (values
		      `(if (cmp ',pattern (rename expr))
			   (exit #f)
			   #f)
		      '()))
		    ((symbol? pattern)
		     (values `(set! ,(var->sym pattern) expr) (list pattern)))
		    ((pair? pattern)
		     (compile-match-list pattern))
		    ((vector? pattern)
		     (compile-match-vector pattern))
		    (else
		     (values
		      `(if (not (eqv? ',pattern expr))
			   (exit #f))
		      '())))))
	   (compile-match-list
	    (lambda (pattern)
	      (let loop ((pattern pattern)
			 (matches '())
			 (vars '())
			 (accessor 'expr))
		(cond ((not (pair? (cdr pattern)))
		       (let*-values (((match1 vars1) (compile-match-base (car pattern)))
				     ((match2 vars2) (compile-match-base (cdr pattern))))
			 (values
			  `(begin ,@(reverse matches)
				  (if (pair? ,accessor)
				      (begin
					(let ((expr (car ,accessor)))
					  ,match1)
					(let ((expr (cdr ,accessor)))
					  ,match2))
				      (exit #f)))
			  (append vars (append vars1 vars2)))))
		      ((eq? (cadr pattern) ellipsis)
		       (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
			 (values
			  `(begin ,@(reverse matches)
				  (let ((expr (reverse* ,accessor)))
				    ,match-r))
			  (append vars vars-r))))
		      (else
		       (let-values (((match1 vars1) (compile-match-base (car pattern))))
			 (loop (cdr pattern)
			       (cons `(if (pair? ,accessor)
					  (let ((expr (car,accessor)))
					    ,match1)
					  (exit #f))
				     matches)
			       (append vars vars1)
			       `(cdr ,accessor))))))))
	   (compile-match-list-reverse
	    (lambda (pattern)
	      (let loop ((pattern (reverse* pattern))
			 (matches '())
			 (vars '())
			 (accessor 'expr))
		(cond ((eq? (car pattern) ellipsis)
		       (let-values (((match1 vars1) (compile-match-ellipsis (cdr pattern))))
			 (values
			  `(begin ,@(reverse matches)
				  (let ((expr (reverse* (cons '() ,accessor))))
				    ,match1))
			  (append vars vars1))))
		      (else
		       (let-values (((match1 vars1) (compile-match-base (car pattern))))
			 (loop (cdr pattern)
			       (cons `(let ((expr (car expr))) ,match1) matches)
			       (append vars vars1)
			       `(cdr ,accessor))))))))
	   (compile-match-ellipsis
	    (lambda (pattern)
	      (let-values (((match vars) (compile-match-base pattern)))
		(values
		 `(let loop ((expr expr))
		    (if (not (null? expr))
			(let ,(map (lambda (var) `(,(var->sym var) '())) vars)
			  (let ((expr (car expr)))
			    ,match)
			  ,@(map
			     (lambda (var)
			       `(set! ,(var->sym (push-var var))
				      (cons ,(var->sym var) ,(var->sym (push-var var)))))
			     vars)
			  (loop (cdr expr)))))
		 (map push-var vars)))))
	   (compile-match-vector
	    (lambda (pattern)
	      (values '() '()))))
    
    (let-values (((match vars) (compile-match-base (cdr pattern))))
      (values `(let ((expr (cdr expr)))
		 ,match
		 #t)
	      vars))))


;;; compile expand
(define (compile-expand ellipsis reserved template)
  (letrec ((compile-expand-base
	    (lambda (template ellipsis-valid)
	      (cond ((member template reserved)
		     (values (var->sym template) (list template)))
		    ((symbol? template)
		     (values `(rename ',template) '()))
		    ((pair? template)
		     (compile-expand-list template ellipsis-valid))
		    ((vector? template)
		     (compile-expand-vector template ellipsis-valid))
		    (else
		     (values `',template '())))))
	   
	   (compile-expand-list
	    (lambda (template ellipsis-valid)
	      (let loop ((template template)
			 (expands '())
			 (vars '()))
		(cond ((and ellipsis-valid
			    (pair? template)
			    (eq? (car template) ellipsis))
		       (if (and (pair? (cdr template)) (null? (cddr template)))
			   (compile-expand-base (cadr template) #f)
			   (values '(syntax-error "invalid rule") '())))
		      ((not (pair? template))
		       (let-values (((expand1 vars1)
				     (compile-expand-base template ellipsis-valid)))
			 (values
			  `(,'quasiquote (,@(reverse expands) . (,'unquote ,expand1)))
			  (append vars vars1))))
		      ((not (pair? (cdr template)))
		       (let*-values (((expand1 vars1)
				      (compile-expand-base (car template) ellipsis-valid))
				     ((expand2 vars2)
				      (compile-expand-base (cdr template) ellipsis-valid)))
			 (values
			  `(,'quasiquote (,@(reverse expands) (,'unquote ,expand1) . (,'unquote ,expand2)))
			  (append (append vars vars1) vars2))))
		      ((and ellipsis-valid
			    (eq? (cadr template) ellipsis))
		       (let-values (((expand1 vars1)
				     (compile-expand-base (car template) ellipsis-valid)))
			 (loop (cddr template)
			       (cons
				`(,'unquote-splicing
				  (map (lambda ,(map var->sym vars1) ,expand1)
				       ,@(map (lambda (v) (var->sym (push-var v))) vars1)))
				expands)
			       (append vars (map push-var vars1)))))
		      (else
		       (let-values (((expand1 vars1)
				     (compile-expand-base (car template) ellipsis-valid)))
			 (loop (cdr template)
			       (cons
				`(,'unquote ,expand1)
				expands)
			       (append vars vars1))))))))
	   
	   (compile-expand-vector
	    (lambda (template elliipsis-valid)
	      (values '() '()))))
    (compile-expand-base template #t)))




;;; main function
(define (expand-clauses clauses)
  (cond ((null? clauses)
	 ''(syntax-error "no matching pattern"))
	((eq? (car clauses) 'mismatch)
	 '(syntax-error "invalid rule"))
	(else
	 (let ((vars (car (car clauses)))
	       (match (cadr (car clauses)))
	       (expand (caddr (car clauses))))
	   `(let ,(map (lambda (v) (list (var->sym v) '())) vars)
	      (let ((result (call/cc (lambda (exit) ,match))))
		(if result
		    ,expand
		    ,(expand-clauses (cdr clauses)))))))))

(define (check-vars vars-match vars-expand)
  #t)

(define (compile-rule ellipsis literals rule)
  (let ((pattern (car rule))
	(template (cadr rule)))
    (let*-values (((match vars-match)
		   (compile-match ellipsis literals pattern))
		  ((expand vars-expand)
		   (compile-expand ellipsis (flatten vars-match) template)))
      (if (check-vars vars-match vars-expand)
	  (list vars-match match expand)
	  'mismatch))))

(define-syntax syntax-rules
  (er-macro-transformer
   (lambda (form r compare)
     (define (normalize-form form)
       (if (and (list? form) (>= (length form) 2))
	   (let ((ellipsis '...)
		 (literals (cadr form))
		 (rules (cddr form)))
	     
	     (when (symbol? literals)
		   (set! ellipsis literals)
		   (set! literals (car rules))
		   (set! rules (cdr rules)))
	     
	     (if (and (list? literals)
		      (every? symbol? literals)
		      (list? rules)
		      (every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
		 `(syntax-rules ,ellipsis ,literals ,@rules)
		 #f))
	   #f))
     
     (let ((form (normalize-form form)))
       (if form
	   (let ((ellipsis (cadr form))
		 (literals (caddr form))
		 (rules (cdddr form)))
	     (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
				 rules)))
	       `(er-macro-transformer
		 (lambda (expr rename cmp)
		   (define (reverse* l)
		     (let loop ((r (car l))
				(l (cdr l)))
		       (if (pair? l)
			   (loop (cons (car l) r) (cdr l))
			   (cons l r))))
		   
		   ,(expand-clauses clauses)))))
	   `(,(r 'syntax-error) "malformed syntax-rules"))))))

(display (macroexpand '(syntax-rules ()
			 ((let name ((var init) ...) body ...)
			  ((lambda ()
			     (define (name var ...)
			       body ...)
			     (name init ...))))
			 ((let ((var init) ...) body ...)
			  ((lambda (var ...) body ...) init ...)))))