~ chicken-core (chicken-5) aa48ba2a0fb40c7f449266c8e5bc5aafdfe644c8

commit aa48ba2a0fb40c7f449266c8e5bc5aafdfe644c8
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jan 13 11:28:36 2010 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jan 13 11:28:36 2010 +0100

    slight compiler-syntax tweaks and more tests

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 7283b427..fb107c60 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1102,8 +1102,8 @@
  'let-compiler-syntax '()
  (##sys#er-transformer
   (syntax-rules ()
-    ((_ ((name transformer) ...) body ...)
-     (##core#let-compiler-syntax ((name transformer) ...) body ...)))))
+    ((_ (binding ...) body ...)
+     (##core#let-compiler-syntax (binding ...) body ...)))))
 
 
 ;;; Just in case someone forgets
diff --git a/chicken.h b/chicken.h
index 690880e8..7b4c309e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1103,7 +1103,7 @@ extern double trunc(double);
 #define C_null_pointerp(x)              C_mk_bool((void *)C_u_i_car(x) == NULL)
 #define C_update_pointer(p, ptr)        (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
 #define C_copy_pointer(from, to)        (C_set_block_item(to, 0, C_u_i_car(from)), C_SCHEME_UNDEFINED)
-#define C_pointer_to_object(ptr)        ((C_word*)C_block_item(ptr, 0))
+#define C_pointer_to_object(ptr)        C_block_item(ptr, 0)
 
 #define C_direct_return(dk, x)          (C_kontinue(dk, x), C_SCHEME_UNDEFINED)
 
diff --git a/compiler.scm b/compiler.scm
index a728f9e4..d12c7cb6 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -749,7 +749,7 @@
 		       ((##core#define-compiler-syntax)
 			(let* ((var (cadr x))
 			       (body (caddr x))
-			       (name (##sys#strip-syntax var se #t)))
+			       (name (##sys#strip-syntax var se #f)))
 			  (when body
 			    (set! compiler-syntax
 			      (alist-cons
@@ -777,7 +777,7 @@
 			(let ((bs (map
 				   (lambda (b)
 				     (##sys#check-syntax 'let-compiler-syntax b '(symbol . #(_ 0 1)))
-				     (let ((name (##sys#strip-syntax (car b) se #t)))
+				     (let ((name (##sys#strip-syntax (car b) se #f)))
 				       (list 
 					name 
 					(and (pair? (cdr b))
diff --git a/tests/compiler-syntax-tests.scm b/tests/compiler-syntax-tests.scm
index 36d15b70..382fbb46 100644
--- a/tests/compiler-syntax-tests.scm
+++ b/tests/compiler-syntax-tests.scm
@@ -27,5 +27,39 @@
 (module m2 ()
   (import scheme chicken (prefix m1 m-))
   (print (m-bar 10))
-  (print (m-bar 10 23))
+  (assert (= 9 (m-bar 10)))
   (print (+ 4 3)))
+
+(define (goo x) `(goo ,x))
+
+(assert (eq? 'goo (car (goo 1))))
+
+(define-compiler-syntax goo
+  (syntax-rules ()
+    ((_ x) `(cs-goo ,x))))
+
+(print (goo 2))
+(assert (eq? 'cs-goo (car (goo 2))))
+
+(define-compiler-syntax goo)
+
+(assert (eq? 'goo (car (goo 3))))
+
+(define-compiler-syntax goo
+  (syntax-rules ()
+    ((_ x) `(cs-goo2 ,x))))
+
+(let-compiler-syntax ((goo))
+		     (assert (eq? 'goo (car (goo 4)))))
+
+(assert (eq? 'cs-goo2 (car (goo 5))))
+
+(module bar (xxx)
+  (import scheme chicken)
+  (define (xxx) 'yyy)			; ineffective - suboptimal
+  ;(assert (eq? 'yyy (xxx)))
+  (define-compiler-syntax xxx
+    (syntax-rules ()
+      ((_) 'zzz)))
+  (print (xxx))
+  (assert (eq? 'zzz (xxx))))