Merge branch 'letrec-syntax'

docs/lang.rst

@@ -58,7 +58,7 @@ section                                          status     comments
 5.3.1 Top level definitions                      yes
 5.3.2 Internal definitions                       yes        TODO: interreferential definitions
 5.3.3 Multiple-value definitions                 yes
-5.4 Syntax definitions                           yes        TODO: internal macro definition is not supported.
+5.4 Syntax definitions                           yes
 5.5 Recored-type definitions                     yes
 5.6.1 Library Syntax                             incomplete In picrin, libraries can be reopend and can be nested.
 5.6.2 Library example                            N/A

piclib/built-in.scm

@@ -292,6 +292,17 @@
                           `(,(r 'begin) ,@(cdar clauses)))
                         ,(loop (cdr clauses))))))))))
 
+  (define-syntax letrec-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         `(let ()
+            ,@(map (lambda (x)
+                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))
+                   formal)
+            ,@body)))))
+
   (define-syntax syntax-error
     (er-macro-transformer
      (lambda (expr rename compare)
@@ -317,6 +328,7 @@
           and or
           cond case else =>
           do when unless
+          letrec-syntax
           _ ... syntax-error))
 
 
@@ -629,6 +641,7 @@
         and or
         cond case else =>
         do when unless
+        letrec-syntax
         _ ... syntax-error)
 
 (export let-values
@@ -1412,42 +1425,27 @@
 
   (define-syntax case-lambda
     (syntax-rules ()
-      ((case-lambda
+      ((case-lambda (params body0 ...) ...)
-        (?a1 ?e1 ...)
-        ?clause1 ...)
        (lambda args
-         (let ((l (length args)))
+         (let ((len (length args)))
-           (case-lambda "CLAUSE" args l
+           (letrec-syntax
-                        (?a1 ?e1 ...)
+               ((cl (syntax-rules ::: ()
-                        ?clause1 ...))))
+                      ((cl)
-      ((case-lambda "CLAUSE" ?args ?l
+                       (error "no matching clause"))
-                    ((?a1 ...) ?e1 ...)
+                      ((cl ((p :::) . body) . rest)
-                    ?clause1 ...)
+                       (if (= len (length '(p :::)))
-       (if (= ?l (length '(?a1 ...)))
+                           (apply (lambda (p :::)
-           (apply (lambda (?a1 ...) ?e1 ...) ?args)
+                                    . body)
-           (case-lambda "CLAUSE" ?args ?l
+                                  args)
-                        ?clause1 ...)))
+                           (cl . rest)))
-      ((case-lambda "CLAUSE" ?args ?l
+                      ((cl ((p ::: . tail) . body)
-                    ((?a1 . ?ar) ?e1 ...)
+                           . rest)
-                    ?clause1 ...)
+                       (if (>= len (length '(p :::)))
-       (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
+                           (apply
-                    ?clause1 ...))
+                            (lambda (p ::: . tail)
-      ((case-lambda "CLAUSE" ?args ?l
+                              . body)
-                    (?a1 ?e1 ...)
+                            args)
-                    ?clause1 ...)
+                           (cl . rest))))))
-       (let ((?a1 ?args))
+             (cl (params body0 ...) ...)))))))
-         ?e1 ...))
-      ((case-lambda "CLAUSE" ?args ?l)
-       (error "Wrong number of arguments to CASE-LAMBDA."))
-      ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
-                    ?clause1 ...)
-       (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
-                    ?clause1 ...))
-      ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
-                    ?clause1 ...)
-       (if (>= ?l ?k)
-           (apply (lambda ?al ?e1 ...) ?args)
-           (case-lambda "CLAUSE" ?args ?l
-                        ?clause1 ...)))))
 
   (export case-lambda))

src/macro.c

@@ -34,7 +34,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren
 {
   xh_entry *e;
 
-  UNUSED(pic);
+  if (! pic_interned_p(pic, sym)) {
+    if (rename != NULL) {
+      *rename = sym;
+    }
+    return true;
+  }
 
   if ((e = xh_get_int(&senv->renames, sym)) == NULL) {
     return false;
@@ -73,9 +78,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c
 {
   pic_sym rename;
 
-  if (! pic_interned_p(pic, sym)) {
-    return sym;
-  }
   while (true) {
     if (pic_find_rename(pic, senv, sym, &rename)) {
       return rename;

t/r7rs-tests.scm

@@ -464,24 +464,24 @@
     (let ((x 'inner))
       (m)))))
 
-;; (test 7 (letrec-syntax
+(test 7 (letrec-syntax
-;;   ((my-or (syntax-rules ()
+  ((my-or (syntax-rules ()
-;;             ((my-or) #f)
+            ((my-or) #f)
-;;             ((my-or e) e)
+            ((my-or e) e)
-;;             ((my-or e1 e2 ...)
+            ((my-or e1 e2 ...)
-;;              (let ((temp e1))
+             (let ((temp e1))
-;;                (if temp
+               (if temp
-;;                    temp
+                   temp
-;;                    (my-or e2 ...)))))))
+                   (my-or e2 ...)))))))
-;;   (let ((x #f)
+  (let ((x #f)
-;;         (y 7)
+        (y 7)
-;;         (temp 8)
+        (temp 8)
-;;         (let odd?)
+        (let odd?)
-;;         (if even?))
+        (if even?))
-;;     (my-or x
+    (my-or x
-;;            (let temp)
+           (let temp)
-;;            (if y)
+           (if y)
-;;            y))))
+           y))))
 
 (define-syntax be-like-begin
   (syntax-rules ()