conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'letrec-syntax'

This commit is contained in:
Yuichi Nishiwaki 2014-07-16 14:47:54 +09:00
parent b1962ef61b bdcb83296e
commit 9fd56ad851
4 changed files with 59 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
docs/lang.rst
View File

@ -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

70
piclib/built-in.scm
View File

@ -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
(?a1 ?e1 ...)
?clause1 ...)
((case-lambda (params body0 ...) ...)
(lambda args
(let ((l (length args)))
(case-lambda "CLAUSE" args l
(?a1 ?e1 ...)
?clause1 ...))))
((case-lambda "CLAUSE" ?args ?l
((?a1 ...) ?e1 ...)
?clause1 ...)
(if (= ?l (length '(?a1 ...)))
(apply (lambda (?a1 ...) ?e1 ...) ?args)
(case-lambda "CLAUSE" ?args ?l
?clause1 ...)))
((case-lambda "CLAUSE" ?args ?l
((?a1 . ?ar) ?e1 ...)
?clause1 ...)
(case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
?clause1 ...))
((case-lambda "CLAUSE" ?args ?l
(?a1 ?e1 ...)
?clause1 ...)
(let ((?a1 ?args))
?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 ...)))))
(let ((len (length args)))
(letrec-syntax
((cl (syntax-rules ::: ()
((cl)
(error "no matching clause"))
((cl ((p :::) . body) . rest)
(if (= len (length '(p :::)))
(apply (lambda (p :::)
. body)
args)
(cl . rest)))
((cl ((p ::: . tail) . body)
. rest)
(if (>= len (length '(p :::)))
(apply
(lambda (p ::: . tail)
. body)
args)
(cl . rest))))))
(cl (params body0 ...) ...)))))))
(export case-lambda))

10
src/macro.c
View File

@ -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;

36
t/r7rs-tests.scm
View File

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