From 388987c55b6bcda1da8c5c8edc685734f650fb71 Mon Sep 17 00:00:00 2001
From: Yuito Murase <themamedaifuku@gmail.com>
Date: Thu, 3 Apr 2014 15:34:55 +0900
Subject: [PATCH] move code from piclib/syntax-rules.scm to piclib/built-in.scm

---
 piclib/built-in.scm     | 326 ++++++++++++++++++++++++++++++++++++++++
 piclib/syntax-rules.scm | 321 ---------------------------------------
 2 files changed, 326 insertions(+), 321 deletions(-)
 delete mode 100644 piclib/syntax-rules.scm

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index ddf6323c..aad36985 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -918,3 +918,329 @@
 	(make-promise% #f obj)))
 
   (export delay-force delay force make-promise promise?))
+
+;;; syntax-rules
+(define-library (picrin syntax-rules)
+  (import (scheme base)
+	  (scheme cxr)
+	  (picrin macro))
+
+  ;;; utility functions
+  (define (reverse* l)
+    ;; (reverse* '(a b c d . e)) => (e d c b a)
+    (let loop ((a '())
+	       (d l))
+      (if (pair? d)
+	  (loop (cons (car d) a) (cdr d))
+	  (cons d a))))
+
+  (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)))))
+
+  (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))))))
+
+  ;;; main function
+  (define-syntax syntax-rules
+    (er-macro-transformer
+     (lambda (form r compare)
+       (define _define (r 'define))
+       (define _let (r 'let))
+       (define _if (r 'if))
+       (define _begin (r 'begin))
+       (define _lambda (r 'lambda))
+       (define _set! (r 'set!))
+       (define _not (r 'not))
+       (define _and (r 'and))
+       (define _car (r 'car))
+       (define _cdr (r 'cdr))
+       (define _cons (r 'cons))
+       (define _pair? (r 'pair?))
+       (define _null? (r 'null?))
+       (define _symbol? (r 'symbol?))
+       (define _eqv? (r 'eqv?))
+       (define _string=? (r 'string=?))
+       (define _map (r 'map))
+       (define _vector->list (r 'vector->list))
+       (define _list->vector (r 'list->vector))
+       (define _quote (r 'quote))
+       (define _quasiquote (r 'quasiquote))
+       (define _unquote (r 'unquote))
+       (define _unquote-splicing (r 'unquote-splicing))
+       (define _syntax-error (r 'syntax-error))
+       (define _call/cc (r 'call/cc))
+       (define _er-macro-transformer (r 'er-macro-transformer))
+
+       (define (compile-match ellipsis literals pattern)
+	 (letrec ((compile-match-base
+		   (lambda (pattern)
+		     (cond ((compare pattern (r '_)) (values #f '()))
+			   ((member pattern literals compare)
+			    (values
+			     `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
+				    #f
+				    (exit #f))
+			     '()))
+			   ((and ellipsis (compare pattern ellipsis))
+			    (values `(,_syntax-error "invalid pattern") '()))
+			   ((symbol? pattern)
+			    (values `(,_set! ,(var->sym pattern) expr) (list pattern)))
+			   ((pair? pattern)
+			    (compile-match-list pattern))
+			   ((vector? pattern)
+			    (compile-match-vector pattern))
+			   ((string? pattern)
+			    (values
+			     `(,_if (,_not (,_string=? ',pattern expr))
+				    (exit #f))
+			     '()))
+			   (else
+			    (values
+			     `(,_if (,_not (,_eqv? ',pattern expr))
+				    (exit #f))
+			     '())))))
+
+		  (compile-match-list
+		   (lambda (pattern)
+		     (let loop ((pattern pattern)
+				(matches '())
+				(vars '())
+				(accessor 'expr))
+		       (cond ;; (hoge)
+			((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)))))
+			;; (hoge ... rest args)
+			((and ellipsis (compare (cadr pattern) ellipsis))
+			 (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
+			   (values
+			    `(,_begin ,@(reverse matches)
+				      (,_let ((expr (,_let loop ((a ())
+								 (d ,accessor))
+							   (,_if (,_pair? d)
+								 (loop (,_cons (,_car d) a) (,_cdr d))
+								 (,_cons d a)))))
+					     ,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 ((and ellipsis (compare (car pattern) ellipsis))
+			      (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
+				(values
+				 `(,_begin ,@(reverse matches)
+					   (,_let ((expr ,accessor))
+						  ,match1))
+				 (append vars vars1))))
+			     (else
+			      (let-values (((match1 vars1) (compile-match-base (car pattern))))
+				(loop (cdr pattern)
+				      (cons `(,_let ((expr (,_car ,accessor))) ,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)
+		     (let-values (((match vars) (compile-match-list (vector->list pattern))))
+		       (values
+			`(,_let ((expr (,_vector->list expr)))
+				,match)
+			vars)))))
+
+	   (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 compare)
+			    (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 ;; (... hoge)
+			((and ellipsis-valid
+			      (pair? template)
+			      (compare (car template) ellipsis))
+			 (if (and (pair? (cdr template)) (null? (cddr template)))
+			     (compile-expand-base (cadr template) #f)
+			     (values '(,_syntax-error "invalid template") '())))
+			;; hoge
+			((not (pair? template))
+			 (let-values (((expand1 vars1)
+				       (compile-expand-base template ellipsis-valid)))
+			   (values
+			    `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
+			    (append vars vars1))))
+			;; (a ... rest syms)
+			((and ellipsis-valid
+			      (pair? (cdr template))
+			      (compare (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 ellipsis-valid)
+		     (let-values (((expand1 vars1)
+				   (compile-expand-list (vector->list template) ellipsis-valid)))
+		       `(,_list->vector ,expand1)
+		       vars1))))
+
+	   (compile-expand-base template ellipsis)))
+
+       (define (check-vars vars-pattern vars-template)
+	 ;;fixme
+	 #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 (expand-clauses clauses rename)
+	 (cond ((null? clauses)
+		`(,_quote (syntax-error "no matching pattern")))
+	       ((compare (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) rename))))))))
+
+       (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 (symbol? ellipsis)
+			(list? literals)
+			(every? symbol? literals)
+			(list? rules)
+			(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
+		   (if (member ellipsis literals compare)
+		       `(syntax-rules #f ,literals ,@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)
+			     ,(expand-clauses clauses r)))))
+
+	     `(,_syntax-error "malformed syntax-rules"))))))
+
+  (export syntax-rules))
+
+(import (picrin syntax-rules))
+(export syntax-rules)
diff --git a/piclib/syntax-rules.scm b/piclib/syntax-rules.scm
deleted file mode 100644
index a47e0bb1..00000000
--- a/piclib/syntax-rules.scm
+++ /dev/null
@@ -1,321 +0,0 @@
-(define-library (picrin syntax-rules)
-  (import (scheme base)
-	  (scheme cxr)
-	  (picrin macro))
-
-  ;;; utility functions
-  (define (reverse* l)
-    ;; (reverse* '(a b c d . e)) => (e d c b a)
-    (let loop ((a '())
-	       (d l))
-      (if (pair? d)
-	  (loop (cons (car d) a) (cdr d))
-	  (cons d a))))
-
-  (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)))))
-
-  (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))))))
-
-  ;;; main function
-  (define-syntax syntax-rules
-    (er-macro-transformer
-     (lambda (form r compare)
-       (define _define (r 'define))
-       (define _let (r 'let))
-       (define _if (r 'if))
-       (define _begin (r 'begin))
-       (define _lambda (r 'lambda))
-       (define _set! (r 'set!))
-       (define _not (r 'not))
-       (define _and (r 'and))
-       (define _car (r 'car))
-       (define _cdr (r 'cdr))
-       (define _cons (r 'cons))
-       (define _pair? (r 'pair?))
-       (define _null? (r 'null?))
-       (define _symbol? (r 'symbol?))
-       (define _eqv? (r 'eqv?))
-       (define _string=? (r 'string=?))
-       (define _map (r 'map))
-       (define _vector->list (r 'vector->list))
-       (define _list->vector (r 'list->vector))
-       (define _quote (r 'quote))
-       (define _quasiquote (r 'quasiquote))
-       (define _unquote (r 'unquote))
-       (define _unquote-splicing (r 'unquote-splicing))
-       (define _syntax-error (r 'syntax-error))
-       (define _call/cc (r 'call/cc))
-       (define _er-macro-transformer (r 'er-macro-transformer))
-
-       (define (compile-match ellipsis literals pattern)
-	 (letrec ((compile-match-base
-		   (lambda (pattern)
-		     (cond ((compare pattern (r '_)) (values #f '()))
-			   ((member pattern literals compare)
-			    (values
-			     `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
-				    #f
-				    (exit #f))
-			     '()))
-			   ((and ellipsis (compare pattern ellipsis))
-			    (values `(,_syntax-error "invalid pattern") '()))
-			   ((symbol? pattern)
-			    (values `(,_set! ,(var->sym pattern) expr) (list pattern)))
-			   ((pair? pattern)
-			    (compile-match-list pattern))
-			   ((vector? pattern)
-			    (compile-match-vector pattern))
-			   ((string? pattern)
-			    (values
-			     `(,_if (,_not (,_string=? ',pattern expr))
-				    (exit #f))
-			     '()))
-			   (else
-			    (values
-			     `(,_if (,_not (,_eqv? ',pattern expr))
-				    (exit #f))
-			     '())))))
-
-		  (compile-match-list
-		   (lambda (pattern)
-		     (let loop ((pattern pattern)
-				(matches '())
-				(vars '())
-				(accessor 'expr))
-		       (cond ;; (hoge)
-			((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)))))
-			;; (hoge ... rest args)
-			((and ellipsis (compare (cadr pattern) ellipsis))
-			 (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
-			   (values
-			    `(,_begin ,@(reverse matches)
-				      (,_let ((expr (,_let loop ((a ())
-								 (d ,accessor))
-							   (,_if (,_pair? d)
-								 (loop (,_cons (,_car d) a) (,_cdr d))
-								 (,_cons d a)))))
-					     ,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 ((and ellipsis (compare (car pattern) ellipsis))
-			      (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
-				(values
-				 `(,_begin ,@(reverse matches)
-					   (,_let ((expr ,accessor))
-						  ,match1))
-				 (append vars vars1))))
-			     (else
-			      (let-values (((match1 vars1) (compile-match-base (car pattern))))
-				(loop (cdr pattern)
-				      (cons `(,_let ((expr (,_car ,accessor))) ,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)
-		     (let-values (((match vars) (compile-match-list (vector->list pattern))))
-		       (values
-			`(,_let ((expr (,_vector->list expr)))
-				,match)
-			vars)))))
-
-	   (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 compare)
-			    (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 ;; (... hoge)
-			((and ellipsis-valid
-			      (pair? template)
-			      (compare (car template) ellipsis))
-			 (if (and (pair? (cdr template)) (null? (cddr template)))
-			     (compile-expand-base (cadr template) #f)
-			     (values '(,_syntax-error "invalid template") '())))
-			;; hoge
-			((not (pair? template))
-			 (let-values (((expand1 vars1)
-				       (compile-expand-base template ellipsis-valid)))
-			   (values
-			    `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
-			    (append vars vars1))))
-			;; (a ... rest syms)
-			((and ellipsis-valid
-			      (pair? (cdr template))
-			      (compare (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 ellipsis-valid)
-		     (let-values (((expand1 vars1)
-				   (compile-expand-list (vector->list template) ellipsis-valid)))
-		       `(,_list->vector ,expand1)
-		       vars1))))
-
-	   (compile-expand-base template ellipsis)))
-
-       (define (check-vars vars-pattern vars-template)
-	 ;;fixme
-	 #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 (expand-clauses clauses rename)
-	 (cond ((null? clauses)
-		`(,_quote (syntax-error "no matching pattern")))
-	       ((compare (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) rename))))))))
-
-       (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 (symbol? ellipsis)
-			(list? literals)
-			(every? symbol? literals)
-			(list? rules)
-			(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
-		   (if (member ellipsis literals compare)
-		       `(syntax-rules #f ,literals ,@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)
-			     ,(expand-clauses clauses r)))))
-
-	     `(,_syntax-error "malformed syntax-rules"))))))
-
-  (export syntax-rules))