From 3e2e49650c7360f7bba03219943334e2eabd3d91 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 24 Jan 2014 00:21:17 -0500 Subject: [PATCH 1/3] Implement SRFI-111 Boxes. * module/srfi/srfi-111.scm: New file. * module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-111.scm. * test-suite/tests/srfi-111.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-111.test. * doc/ref/srfi-modules.texi (SRFI-111): New node. --- doc/ref/srfi-modules.texi | 25 +++++++++++++ module/Makefile.am | 3 +- module/srfi/srfi-111.scm | 37 +++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/srfi-111.test | 65 ++++++++++++++++++++++++++++++++++ 5 files changed, 130 insertions(+), 1 deletion(-) create mode 100644 module/srfi/srfi-111.scm create mode 100644 test-suite/tests/srfi-111.test diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 66d5bd1d9..8845c85b3 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -59,6 +59,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-88:: Keyword objects. * SRFI-98:: Accessing environment variables. * SRFI-105:: Curly-infix expressions. +* SRFI-111:: Boxes. @end menu @@ -5181,6 +5182,30 @@ directive @code{#!curly-infix-and-bracket-lists}. For example: For more information on reader options, @xref{Scheme Read}. +@node SRFI-111 +@subsection SRFI-111 Boxes. +@cindex SRFI-111 + +@uref{http://srfi.schemers.org/srfi-111/srfi-111.html, SRFI-111} +provides boxes: objects with a single mutable cell. + +@deffn {Scheme Procedure} box value +Return a newly allocated box whose contents is initialized to +@var{value}. +@end deffn + +@deffn {Scheme Procedure} box? obj +Return true if @var{obj} is a box, otherwise return false. +@end deffn + +@deffn {Scheme Procedure} unbox box +Return the current contents of @var{box}. +@end deffn + +@deffn {Scheme Procedure} set-box! box value +Set the contents of @var{box} to @var{value}. +@end deffn + @c srfi-modules.texi ends here @c Local Variables: diff --git a/module/Makefile.am b/module/Makefile.am index 8a7befd26..47b9c2ce0 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -295,7 +295,8 @@ SRFI_SOURCES = \ srfi/srfi-67.scm \ srfi/srfi-69.scm \ srfi/srfi-88.scm \ - srfi/srfi-98.scm + srfi/srfi-98.scm \ + srfi/srfi-111.scm RNRS_SOURCES = \ rnrs/base.scm \ diff --git a/module/srfi/srfi-111.scm b/module/srfi/srfi-111.scm new file mode 100644 index 000000000..3d3cd896b --- /dev/null +++ b/module/srfi/srfi-111.scm @@ -0,0 +1,37 @@ +;;; srfi-111.scm -- SRFI 111 Boxes + +;; Copyright (C) 2014 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 (srfi srfi-111) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (box box? unbox set-box!)) + +(cond-expand-provide (current-module) '(srfi-111)) + +(define-record-type + (box value) + box? + (value unbox set-box!)) + +(set-record-type-printer! + (lambda (box port) + (display "#string (object-address box) 16) port) + (display " value: ") + (write (unbox box) port) + (display ">" port))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 01ffd1c77..00f62fe32 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -139,6 +139,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-69.test \ tests/srfi-88.test \ tests/srfi-105.test \ + tests/srfi-111.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-111.test b/test-suite/tests/srfi-111.test new file mode 100644 index 000000000..e2d76c6d5 --- /dev/null +++ b/test-suite/tests/srfi-111.test @@ -0,0 +1,65 @@ +;;;; srfi-111.test --- Test suite for SRFI-111 (Boxes). -*- scheme -*- +;;;; +;;;; Copyright (C) 2014 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-srfi-111) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-111)) + +(with-test-prefix "srfi-111" + + (let ((test-vals '(#f #t #\space "string" -5 #e1e100 1e-30 #(a vector)))) + (pass-if-equal "box and unbox" + test-vals + (map (lambda (x) + (unbox (box x))) + test-vals)) + + (pass-if "box?" + (and (box? (box 5)) + (not (any box? test-vals)))) + + (pass-if-equal "set-box!" + "string" + (let ((b (box #f))) + (set-box! b "string") + (unbox b))) + + (pass-if "eq? on boxes" + (let ((box1 (box #f)) + (box2 (box #f))) + (and (eq? box1 box1) + (eq? box2 box2) + (not (eq? box1 box2))))) + + (pass-if "eqv? on boxes" + (let ((box1 (box #f)) + (box2 (box #f))) + (and (eqv? box1 box1) + (eqv? box2 box2) + (not (eqv? box1 box2))))) + + (pass-if "equal? on boxes" + (let ((box1 (box "foo")) + (box2 (box "bar"))) + (and (equal? box1 box1) + (equal? box2 box2) + (not (equal? box1 box2)) + ;; Guile extension, not guaranteed by SRFI-111. + (begin (set-box! box2 (string #\f #\o #\o)) + (equal? box1 box2))))))) From a7a4ba6a2de7dee9b5c9e2fa5e0c3caf022c0b14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Jan 2014 22:28:08 +0100 Subject: [PATCH 2/3] Minor for-each speedup * module/ice-9/boot-9.scm (for-each): Minor speedup by unrolling tortoise/hare loop. --- module/ice-9/boot-9.scm | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index fe9ae7897..98cefe9c4 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -687,23 +687,22 @@ information is unavailable." (define for-each (case-lambda ((f l) - (let for-each1 ((hare l) (tortoise l) (move? #f)) + (let for-each1 ((hare l) (tortoise l)) (if (pair? hare) - (if move? - (if (eq? tortoise hare) - (scm-error 'wrong-type-arg "for-each" "Circular list: ~S" - (list l) #f) + (begin + (f (car hare)) + (let ((hare (cdr hare))) + (if (pair? hare) (begin + (when (eq? tortoise hare) + (scm-error 'wrong-type-arg "for-each" "Circular list: ~S" + (list l) #f)) (f (car hare)) - (for-each1 (cdr hare) (cdr tortoise) #f))) - (begin - (f (car hare)) - (for-each1 (cdr hare) tortoise #t))) - + (for-each1 (cdr hare) (cdr tortoise)))))) (if (not (null? hare)) (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))))) - + ((f l1 l2) (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f)) (cond From ca5e0414e96886177d883a249edd957d2331db65 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 28 Jan 2014 16:54:10 -0500 Subject: [PATCH 3/3] Add 'positive?' and 'negative?' as primitives. * module/language/tree-il/primitives.scm (*interesting-primitive-names*) (*effect-free-primitives*): Add 'positive?' and 'negative?'. (*primitive-expand-table*): Add primitive expanders for 'positive?' and 'negative?'. --- module/language/tree-il/primitives.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 15b5c44c9..f140eeca2 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -35,7 +35,7 @@ ;; When adding to this, be sure to update *multiply-valued-primitives* ;; if appropriate. -(define *interesting-primitive-names* +(define *interesting-primitive-names* '(apply @apply call-with-values @call-with-values call-with-current-continuation @call-with-current-continuation @@ -45,7 +45,7 @@ values eq? eqv? equal? memq memv - = < > <= >= zero? + = < > <= >= zero? positive? negative? + * - / 1- 1+ quotient remainder modulo ash logand logior logxor lognot not @@ -150,7 +150,7 @@ (define *effect-free-primitives* `(values eq? eqv? equal? - = < > <= >= zero? + = < > <= >= zero? positive? negative? ash logand logior logxor lognot + * - / 1- 1+ quotient remainder modulo not @@ -331,6 +331,12 @@ (define-primitive-expander zero? (x) (= x 0)) +(define-primitive-expander positive? (x) + (> x 0)) + +(define-primitive-expander negative? (x) + (< x 0)) + ;; FIXME: All the code that uses `const?' is redundant with `peval'. (define-primitive-expander +