diff options
Diffstat (limited to 'module/srfi/srfi-17.scm')
-rw-r--r-- | module/srfi/srfi-17.scm | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm new file mode 100644 index 000000000..c9cb2abfe --- /dev/null +++ b/module/srfi/srfi-17.scm @@ -0,0 +1,174 @@ +;;; srfi-17.scm --- Generalized set! + +;; Copyright (C) 2001, 2002, 2003, 2006 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 2.1 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 + +;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> + +;;; Commentary: + +;; This is an implementation of SRFI-17: Generalized set! +;; +;; It exports the Guile procedure `make-procedure-with-setter' under +;; the SRFI name `getter-with-setter' and exports the standard +;; procedures `car', `cdr', ..., `cdddr', `string-ref' and +;; `vector-ref' as procedures with setters, as required by the SRFI. +;; +;; SRFI-17 was heavily criticized during its discussion period but it +;; was finalized anyway. One issue was its concept of globally +;; associating setter "properties" with (procedure) values, which is +;; non-Schemy. For this reason, this implementation chooses not to +;; provide a way to set the setter of a procedure. In fact, (set! +;; (setter PROC) SETTER) signals an error. The only way to attach a +;; setter to a procedure is to create a new object (a "procedure with +;; setter") via the `getter-with-setter' procedure. This procedure is +;; also specified in the SRFI. Using it avoids the described +;; problems. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-17) + :export (getter-with-setter) + :replace (;; redefined standard procedures + setter + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar + cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr + cdddar cddddr string-ref vector-ref)) + +(cond-expand-provide (current-module) '(srfi-17)) + +;;; Procedures + +(define getter-with-setter make-procedure-with-setter) + +(define setter + (getter-with-setter + (@ (guile) setter) + (lambda args + (error "Setting setters is not supported for a good reason.")))) + +;;; Redefine R5RS procedures to appropriate procedures with setters + +(define (compose-setter setter location) + (lambda (obj value) + (setter (location obj) value))) + +(define car + (getter-with-setter (@ (guile) car) + set-car!)) +(define cdr + (getter-with-setter (@ (guile) cdr) + set-cdr!)) + +(define caar + (getter-with-setter (@ (guile) caar) + (compose-setter set-car! (@ (guile) car)))) +(define cadr + (getter-with-setter (@ (guile) cadr) + (compose-setter set-car! (@ (guile) cdr)))) +(define cdar + (getter-with-setter (@ (guile) cdar) + (compose-setter set-cdr! (@ (guile) car)))) +(define cddr + (getter-with-setter (@ (guile) cddr) + (compose-setter set-cdr! (@ (guile) cdr)))) + +(define caaar + (getter-with-setter (@ (guile) caaar) + (compose-setter set-car! (@ (guile) caar)))) +(define caadr + (getter-with-setter (@ (guile) caadr) + (compose-setter set-car! (@ (guile) cadr)))) +(define cadar + (getter-with-setter (@ (guile) cadar) + (compose-setter set-car! (@ (guile) cdar)))) +(define caddr + (getter-with-setter (@ (guile) caddr) + (compose-setter set-car! (@ (guile) cddr)))) +(define cdaar + (getter-with-setter (@ (guile) cdaar) + (compose-setter set-cdr! (@ (guile) caar)))) +(define cdadr + (getter-with-setter (@ (guile) cdadr) + (compose-setter set-cdr! (@ (guile) cadr)))) +(define cddar + (getter-with-setter (@ (guile) cddar) + (compose-setter set-cdr! (@ (guile) cdar)))) +(define cdddr + (getter-with-setter (@ (guile) cdddr) + (compose-setter set-cdr! (@ (guile) cddr)))) + +(define caaaar + (getter-with-setter (@ (guile) caaaar) + (compose-setter set-car! (@ (guile) caaar)))) +(define caaadr + (getter-with-setter (@ (guile) caaadr) + (compose-setter set-car! (@ (guile) caadr)))) +(define caadar + (getter-with-setter (@ (guile) caadar) + (compose-setter set-car! (@ (guile) cadar)))) +(define caaddr + (getter-with-setter (@ (guile) caaddr) + (compose-setter set-car! (@ (guile) caddr)))) +(define cadaar + (getter-with-setter (@ (guile) cadaar) + (compose-setter set-car! (@ (guile) cdaar)))) +(define cadadr + (getter-with-setter (@ (guile) cadadr) + (compose-setter set-car! (@ (guile) cdadr)))) +(define caddar + (getter-with-setter (@ (guile) caddar) + (compose-setter set-car! (@ (guile) cddar)))) +(define cadddr + (getter-with-setter (@ (guile) cadddr) + (compose-setter set-car! (@ (guile) cdddr)))) +(define cdaaar + (getter-with-setter (@ (guile) cdaaar) + (compose-setter set-cdr! (@ (guile) caaar)))) +(define cdaadr + (getter-with-setter (@ (guile) cdaadr) + (compose-setter set-cdr! (@ (guile) caadr)))) +(define cdadar + (getter-with-setter (@ (guile) cdadar) + (compose-setter set-cdr! (@ (guile) cadar)))) +(define cdaddr + (getter-with-setter (@ (guile) cdaddr) + (compose-setter set-cdr! (@ (guile) caddr)))) +(define cddaar + (getter-with-setter (@ (guile) cddaar) + (compose-setter set-cdr! (@ (guile) cdaar)))) +(define cddadr + (getter-with-setter (@ (guile) cddadr) + (compose-setter set-cdr! (@ (guile) cdadr)))) +(define cdddar + (getter-with-setter (@ (guile) cdddar) + (compose-setter set-cdr! (@ (guile) cddar)))) +(define cddddr + (getter-with-setter (@ (guile) cddddr) + (compose-setter set-cdr! (@ (guile) cdddr)))) + +(define string-ref + (getter-with-setter (@ (guile) string-ref) + string-set!)) + +(define vector-ref + (getter-with-setter (@ (guile) vector-ref) + vector-set!)) + +;;; srfi-17.scm ends here |