diff --git a/module/Makefile.am b/module/Makefile.am index cbe945f95..f5cde7d0f 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -256,6 +256,8 @@ SRFI_SOURCES = \ srfi/srfi-98.scm RNRS_SOURCES = \ + rnrs/6/base.scm \ + rnrs/6/control.scm \ rnrs/bytevector.scm \ rnrs/io/ports.scm diff --git a/module/rnrs/6/base.scm b/module/rnrs/6/base.scm new file mode 100644 index 000000000..cc17d8adc --- /dev/null +++ b/module/rnrs/6/base.scm @@ -0,0 +1,77 @@ +;;; base.scm --- The R6RS base library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs base (6)) + (export boolean? symbol? char? vector? null? pair? number? string? procedure? + + define define-syntax syntax-rules lambda let let* let-values + let*-values letrec begin + + quote lambda if set! cond case + + or and not + + eqv? equal? eq? + + + - * / max min abs numerator denominator gcd lcm floor ceiling + truncate round rationalize real-part imag-part make-rectangular angle + div mod div-and-mod div0 mod0 div0-and-mod0 + + expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan + make-polar magnitude angle + + complex? real? rational? integer? exact? inexact? real-valued? + rational-valued? integer-values? zero? positive? negative? odd? even? + nan? finite? infinite? + + exact inexact = < > <= >= + + number->string string->number + + cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr + cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr + cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr + + list? list length append reverse list-tail list-ref map for-each + + symbol->string symbol->string symbol=? + + char->integer integer->char char=? char? char<=? char>=? + + make-string string string-length string-ref string=? string? + string<=? string>=? substring string-append string->list list->string + string-for-each string-copy + + vector? make-vector vector vector-length vector-ref vector-set! + vector->list list->vector vector-fill! vector-map vector-for-each + + error assertion-violation assert + + call-with-current-continuation call/cc call-with-values dynamic-wind + values apply + + quasiquote unquote unquote-splicing + + let-syntax letrec-syntax + + syntax-rules identifier-syntax) + (import (guile) + (rename (only (guile (6)) for-each map) (for-each vector-for-each) + (map vector-map)) + (srfi srfi-11))) diff --git a/module/rnrs/6/control.scm b/module/rnrs/6/control.scm new file mode 100644 index 000000000..69351c6c7 --- /dev/null +++ b/module/rnrs/6/control.scm @@ -0,0 +1,33 @@ +;;; control.scm --- The R6RS control structures library + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(library (rnrs control (6)) + (export when unless do case-lambda) + (import (rnrs base (6)) + (only (guile) do case-lambda)) + + (define-syntax when + (syntax-rules () + ((when test result1 result2 ...) + (if test (begin result1 result2 ...))))) + + (define-syntax unless + (syntax-rules () + ((unless test result1 result2 ...) + (if (not test) (begin result1 result2 ...)))))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0f49d0577..ca220d270 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -76,6 +76,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/q.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ + tests/r6rs-control.test \ tests/r6rs-ports.test \ tests/rnrs-libraries.test \ tests/ramap.test \ diff --git a/test-suite/tests/r6rs-control.test b/test-suite/tests/r6rs-control.test new file mode 100644 index 000000000..0f099a0f1 --- /dev/null +++ b/test-suite/tests/r6rs-control.test @@ -0,0 +1,34 @@ +;;; r6rs-control.test --- Test suite for R6RS (rnrs control) + +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (test-suite test-rnrs-control) + :use-module ((rnrs control) :version (6)) + :use-module (test-suite lib)) + +(with-test-prefix "when" + (pass-if "when true" + (eq? (when (> 3 2) 'greater) 'greater)) + (pass-if "when false" + (unspecified? (when (< 3 2) 'greater)))) + +(with-test-prefix "unless" + (pass-if "unless true" + (unspecified? (unless (> 3 2) 'less))) + (pass-if "unless false" + (eq? (unless (< 3 2) 'less) 'less)))