From 10bd43d222436a04e7d118f3837e8a8b11ea1d6b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 4 May 2018 12:44:05 +0200 Subject: [PATCH] mes: Support srfi-9-gnu. * module/srfi/srfi-9/gnu.mes: New file. Support srfi-9-gnu. * tests/srfi-9.test: Test it. * tests/srfi-9.test-guile: --- build-aux/build-guile.sh | 1 + check.sh | 2 +- module/mes/test.mes | 6 ++- module/mes/test.scm | 22 +++++++++++ module/srfi/srfi-9.mes | 5 ++- module/srfi/srfi-9/gnu.mes | 37 +++++++++++++++++++ tests/{record.test => srfi-9.test} | 16 +++++--- .../{record.test-guile => srfi-9.test-guile} | 0 8 files changed, 80 insertions(+), 9 deletions(-) create mode 100644 module/mes/test.scm create mode 100644 module/srfi/srfi-9/gnu.mes rename tests/{record.test => srfi-9.test} (76%) rename tests/{record.test-guile => srfi-9.test-guile} (100%) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 73640807..00834fbc 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -31,6 +31,7 @@ mes/as.scm mes/bytevectors.scm mes/elf.scm mes/guile.scm +mes/test.scm mes/M1.scm" export srcdir=. diff --git a/check.sh b/check.sh index 7c4eb0b3..9c8b2fab 100755 --- a/check.sh +++ b/check.sh @@ -41,13 +41,13 @@ tests/cwv.test tests/math.test tests/vector.test tests/srfi-1.test +tests/srfi-9.test tests/srfi-13.test tests/srfi-14.test tests/srfi-43.test tests/optargs.test tests/fluids.test tests/catch.test -tests/record.test tests/getopt-long.test tests/guile.test tests/syntax.test diff --git a/module/mes/test.mes b/module/mes/test.mes index 97c6e601..eddb5673 100644 --- a/module/mes/test.mes +++ b/module/mes/test.mes @@ -25,7 +25,11 @@ ;;; Code: -(mes-use-module (mes base)) +(cond-expand + (mes + (mes-use-module (mes base))) + (else)) + (cond-expand (mes (define mes? #t) diff --git a/module/mes/test.scm b/module/mes/test.scm new file mode 100644 index 00000000..2e27db17 --- /dev/null +++ b/module/mes/test.scm @@ -0,0 +1,22 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define-module (mes test)) +(include-from-path "mes/test.mes") diff --git a/module/srfi/srfi-9.mes b/module/srfi/srfi-9.mes index b09e2597..47767c9d 100644 --- a/module/srfi/srfi-9.mes +++ b/module/srfi/srfi-9.mes @@ -53,9 +53,10 @@ (define (record-getter type field) (let ((i (record-field-index type field))) - (lambda (o) + (lambda (o . field?) (if (not (eq? (record-type o) type)) (error "record getter: record expected" type o) - (vector-ref o i))))) + (if (pair? field?) field + (vector-ref o i)))))) (define (record-setter type field) (let ((i (record-field-index type field))) diff --git a/module/srfi/srfi-9/gnu.mes b/module/srfi/srfi-9/gnu.mes new file mode 100644 index 00000000..8bdad798 --- /dev/null +++ b/module/srfi/srfi-9/gnu.mes @@ -0,0 +1,37 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;;; Commentary: + +;;; srfi-9.mes - GNU immutable records. + +(define-macro (define-immutable-record-type type constructor+params predicate . fields) + `(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields))) + +(define-macro (set-field o getters value) + `(let ((getter ,(car getters))) + (let ((type (record-type ,o)) + (set (getter ,o #t))) + (define (field->value field) + (if (eq? set field) ,value + ((record-getter type field) ,o))) + (let* ((fields (record-fields type)) + (values (map field->value fields))) + (apply (record-constructor type fields) values))))) diff --git a/tests/record.test b/tests/srfi-9.test similarity index 76% rename from tests/record.test rename to tests/srfi-9.test index 97e9471b..799c671a 100755 --- a/tests/record.test +++ b/tests/srfi-9.test @@ -25,14 +25,16 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (srfi srfi-0)) -(mes-use-module (srfi srfi-9)) -(mes-use-module (mes test)) (cond-expand + (mes + (mes-use-module (srfi srfi-9)) + (mes-use-module (srfi srfi-9 gnu)) + (mes-use-module (mes test))) (guile - (use-modules (srfi srfi-9))) - (mes)) + (use-modules (srfi srfi-9)) + (use-modules (srfi srfi-9 gnu)) + (use-modules (mes test)))) (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) @@ -47,4 +49,8 @@ exit $? (pass-if "record" (lexical-token? (make-lexical-token 'x 'y 'z))) +(pass-if-equal "set-field" "baar" + (let ((token (make-lexical-token 'foo "bar" 'baz))) + (lexical-token-category (set-field token (lexical-token-category) "baar")))) + (result 'report) diff --git a/tests/record.test-guile b/tests/srfi-9.test-guile similarity index 100% rename from tests/record.test-guile rename to tests/srfi-9.test-guile