From eafd40c193cfbb27686a721a088fb681813c4de1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Nov 2009 01:44:36 +0900 Subject: [PATCH] adding some handy syntax modules --- lib/srfi/11.module | 28 ++++++++++++++++++++++++++++ lib/srfi/16.module | 24 ++++++++++++++++++++++++ lib/srfi/2.module | 16 ++++++++++++++++ lib/srfi/26.module | 24 ++++++++++++++++++++++++ lib/srfi/6.module | 5 +++++ lib/srfi/8.module | 10 ++++++++++ 6 files changed, 107 insertions(+) create mode 100644 lib/srfi/11.module create mode 100644 lib/srfi/16.module create mode 100644 lib/srfi/2.module create mode 100644 lib/srfi/26.module create mode 100644 lib/srfi/6.module create mode 100644 lib/srfi/8.module diff --git a/lib/srfi/11.module b/lib/srfi/11.module new file mode 100644 index 00000000..386443a2 --- /dev/null +++ b/lib/srfi/11.module @@ -0,0 +1,28 @@ + +(define-module (srfi 11) + (export let-values let*-values) + (import (scheme)) + (body + (define-syntax let*-values + (syntax-rules () + ((let*-values () . body) + (begin . body)) + ((let*-values (((a) expr) . rest) . body) + (let ((a expr)) (let*-values rest . body))) + ((let*-values ((params expr) . rest) . body) + (call-with-values (lambda () expr) + (lambda params (let*-values rest . body)))))) + (define-syntax let-values + (syntax-rules () + ((let-values ("step") (binds ...) bind expr maps () () . body) + (let*-values (binds ... (bind expr)) (let maps . body))) + ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body) + (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body) + (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body)) + ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body) + (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body)) + ((let-values ((params expr) . rest) . body) + (let-values ("step") () () expr () params rest . body)) + )))) + diff --git a/lib/srfi/16.module b/lib/srfi/16.module new file mode 100644 index 00000000..61837146 --- /dev/null +++ b/lib/srfi/16.module @@ -0,0 +1,24 @@ + +(define-module (srfi 16) + (export case-lambda) + (import (scheme)) + (body + (define-syntax %case + (syntax-rules () + ((%case args len n p ((params ...) . body) . rest) + (if (= len (length '(params ...))) + (apply (lambda (params ...) . body) args) + (%case args len 0 () . rest))) + ((%case args len n (p ...) ((x . y) . body) . rest) + (%case args len (+ n 1) (p ... x) (y . body) . rest)) + ((%case args len n (p ...) (y . body) . rest) + (if (>= len n) + (apply (lambda (p ... y) . body) args) + (%case args len 0 () . rest))) + ((%case args len n p) + (error "case-lambda: no cases matched")))) + (define-syntax case-lambda + (syntax-rules () + ((case-lambda . clauses) + (lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))))) + diff --git a/lib/srfi/2.module b/lib/srfi/2.module new file mode 100644 index 00000000..b7addf06 --- /dev/null +++ b/lib/srfi/2.module @@ -0,0 +1,16 @@ + +(define-module (srfi 2) + (export and-let*) + (import (scheme)) + (body + (define-syntax and-let* + (syntax-rules () + ((and-let* () . body) + (begin . body)) + ((and-let* ((var expr) . rest) . body) + (let ((var expr)) + (and var (and-let* rest . body)))) + ((and-let* ((expr) . rest) . body) + (let ((tmp expr)) + (and tmp (and-let* rest . body)))))))) + diff --git a/lib/srfi/26.module b/lib/srfi/26.module new file mode 100644 index 00000000..9ed9aeee --- /dev/null +++ b/lib/srfi/26.module @@ -0,0 +1,24 @@ + +(define-module (srfi 26) + (export cut cute) + (import (scheme)) + (body + (define-syntax %cut + (syntax-rules (<> <...>) + ((%cut e? params args) + (lambda params args)) + ((%cut e? (params ...) (args ...) <> . rest) + (%cut e? (params ... tmp) (args ... tmp) . rest)) + ((%cut e? (params ...) (args ...) <...>) + (%cut e? (params ... . tmp) (apply args ... tmp))) + ((%cut e? (params ...) (args ...) <...> . rest) + (error "cut: non-terminal <...>")) + ((%cut #t (params ...) (args ...) x . rest) + (let ((tmp x)) (%cut #t (params ...) (args ... tmp) . rest))) + ((%cut #f (params ...) (args ...) x . rest) + (%cut #t (params ...) (args ... x) . rest)))) + (define-syntax cut + (syntax-rules () ((cut args ...) (%cut #f () () args ...)))) + (define-syntax cute + (syntax-rules () ((cute args ...) (%cut #t () () args ...)))))) + diff --git a/lib/srfi/6.module b/lib/srfi/6.module new file mode 100644 index 00000000..bbabf209 --- /dev/null +++ b/lib/srfi/6.module @@ -0,0 +1,5 @@ + +(define-module (srfi 6) + (export open-input-string open-output-string get-output-string) + (import (scheme))) + diff --git a/lib/srfi/8.module b/lib/srfi/8.module new file mode 100644 index 00000000..ebe02df7 --- /dev/null +++ b/lib/srfi/8.module @@ -0,0 +1,10 @@ + +(define-module (srfi 8) + (export receive) + (import (scheme)) + (body + (define-syntax receive + (syntax-rules () + ((receive params expr . body) + (call-with-values (lambda () expr) (lambda params . body))))))) +