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

add case-lambda

This commit is contained in:
Yuichi Nishiwaki 2014-07-15 17:51:27 +09:00
parent bb427cf275
commit 1d5fa803aa
2 changed files with 69 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
piclib/built-in.scm
View File

@ -1397,3 +1397,48 @@
(import (picrin syntax-rules)) (import (picrin syntax-rules))
(export syntax-rules) (export syntax-rules)
(define-library (scheme case-lambda)
(import (scheme base))
(define-syntax case-lambda
(syntax-rules ()
((case-lambda
(?a1 ?e1 ...)
?clause1 ...)
(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 ...)))))
(export case-lambda))

49
t/r7rs-tests.scm
View File

@ -36,8 +36,7 @@
(scheme write) (scheme write)
; (scheme eval) ; (scheme eval)
(scheme process-context) (scheme process-context)
; (scheme case-lambda) (scheme case-lambda))
)
;; R7RS test suite. Covers all procedures and syntax in the small ;; R7RS test suite. Covers all procedures and syntax in the small
;; language except `delete-file'. Currently assumes full-unicode ;; language except `delete-file'. Currently assumes full-unicode
@ -409,32 +408,32 @@
(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
;; (define plus (define plus
;; (case-lambda (case-lambda
;; (() 0) (() 0)
;; ((x) x) ((x) x)
;; ((x y) (+ x y)) ((x y) (+ x y))
;; ((x y z) (+ (+ x y) z)) ((x y z) (+ (+ x y) z))
;; (args (apply + args)))) (args (apply + args))))
;; (test 0 (plus)) (test 0 (plus))
;; (test 1 (plus 1)) (test 1 (plus 1))
;; (test 3 (plus 1 2)) (test 3 (plus 1 2))
;; (test 6 (plus 1 2 3)) (test 6 (plus 1 2 3))
;; (test 10 (plus 1 2 3 4)) (test 10 (plus 1 2 3 4))
;; (define mult (define mult
;; (case-lambda (case-lambda
;; (() 1) (() 1)
;; ((x) x) ((x) x)
;; ((x y) (* x y)) ((x y) (* x y))
;; ((x y . z) (apply mult (* x y) z)))) ((x y . z) (apply mult (* x y) z))))
;; (test 1 (mult)) (test 1 (mult))
;; (test 1 (mult 1)) (test 1 (mult 1))
;; (test 2 (mult 1 2)) (test 2 (mult 1 2))
;; (test 6 (mult 1 2 3)) (test 6 (mult 1 2 3))
;; (test 24 (mult 1 2 3 4)) (test 24 (mult 1 2 3 4))
(test-end) (test-end)