srfi/srfi-17.scm

   1 ;;;; srfi-17.scm --- SRFI-17 procedures for Guile
   2
   3 ;;; Copyright (C) 2001 Free Software Foundation, Inc.
   4 ;;; Originally by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or
   7 ;;; modify it under the terms of the GNU General Public License as
   8 ;;; published by the Free Software Foundation; either version 2, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this software; see the file COPYING.  If not, write to
  18 ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  19 ;;; Boston, MA 02111-1307 USA
  20 ;;;
  21 ;;; As a special exception, the Free Software Foundation gives permission
  22 ;;; for additional uses of the text contained in its release of GUILE.
  23 ;;;
  24 ;;; The exception is that, if you link the GUILE library with other files
  25 ;;; to produce an executable, this does not by itself cause the
  26 ;;; resulting executable to be covered by the GNU General Public License.
  27 ;;; Your use of that executable is in no way restricted on account of
  28 ;;; linking the GUILE library code into it.
  29 ;;;
  30 ;;; This exception does not however invalidate any other reasons why
  31 ;;; the executable file might be covered by the GNU General Public License.
  32 ;;;
  33 ;;; This exception applies only to the code released by the
  34 ;;; Free Software Foundation under the name GUILE.  If you copy
  35 ;;; code from other Free Software Foundation releases into a copy of
  36 ;;; GUILE, as the General Public License permits, the exception does
  37 ;;; not apply to the code that you add in this way.  To avoid misleading
  38 ;;; anyone as to the status of such modified files, you must delete
  39 ;;; this exception notice from them.
  40 ;;;
  41 ;;; If you write modifications of your own for GUILE, it is your choice
  42 ;;; whether to permit this exception to apply to your modifications.
  43 ;;; If you do not wish that, delete this exception notice.
  44
  45 ;;; Commentary:
  46
  47 ;; This is an implementation of SRFI-17: Generalized set!
  48 ;;
  49 ;; It exports the Guile procedure `make-procedure-with-setter' under
  50 ;; the SRFI name `getter-with-setter' and exports the standard
  51 ;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
  52 ;; `vector-ref' as procedures with setters, as required by the SRFI.
  53 ;;
  54 ;; SRFI-17 was heavily criticized during its discussion period but it
  55 ;; was finalized anyway.  One issue was its concept of globally
  56 ;; associating setter "properties" with (procedure) values, which is
  57 ;; non-Schemy.  For this reason, this implementation chooses not to
  58 ;; provide a way to set the setter of a procedure.  In fact, (set!
  59 ;; (setter PROC) SETTER) signals an error.  The only way to attach a
  60 ;; setter to a procedure is to create a new object (a "procedure with
  61 ;; setter") via the `getter-with-setter' procedure. This procedure is
  62 ;; also specified in the SRFI.  Using it avoids the described
  63 ;; problems.
  64
  65 ;;; Code:
  66
  67 (define-module (srfi srfi-17)
  68   :export (getter-with-setter
  69            setter
  70            ;; redefined standard procedures
  71            car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
  72            cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
  73            caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
  74            cdddar cddddr string-ref vector-ref))
  75
  76 (cond-expand-provide (current-module) '(srfi-17))
  77
  78 ;;; Procedures
  79
  80 (define getter-with-setter make-procedure-with-setter)
  81
  82 (define setter
  83   (getter-with-setter
  84    setter
  85    (lambda args
  86      (error "Setting setters is not supported for a good reason."))))
  87
  88 ;;; Redefine R5RS procedures to appropriate procedures with setters
  89
  90 (define (compose-setter setter location)
  91   (lambda (obj value)
  92     (setter (location obj) value)))
  93
  94 (define car (getter-with-setter car set-car!))
  95 (define cdr (getter-with-setter cdr set-cdr!))
  96 (define caar (getter-with-setter caar (compose-setter set-car! car)))
  97 (define cadr (getter-with-setter cadr (compose-setter set-car! cdr)))
  98 (define cdar (getter-with-setter cdar (compose-setter set-cdr! car)))
  99 (define cddr (getter-with-setter cddr (compose-setter set-cdr! cdr)))
 100 (define caaar (getter-with-setter caaar (compose-setter set-car! caar)))
 101 (define caadr (getter-with-setter caadr (compose-setter set-car! cadr)))
 102 (define cadar (getter-with-setter cadar (compose-setter set-car! cdar)))
 103 (define caddr (getter-with-setter caddr (compose-setter set-car! cddr)))
 104 (define cdaar (getter-with-setter cdaar (compose-setter set-cdr! caar)))
 105 (define cdadr (getter-with-setter cdadr (compose-setter set-cdr! cadr)))
 106 (define cddar (getter-with-setter cddar (compose-setter set-cdr! cdar)))
 107 (define cdddr (getter-with-setter cdddr (compose-setter set-cdr! cddr)))
 108 (define caaaar (getter-with-setter caaaar (compose-setter set-car! caaar)))
 109 (define caaadr (getter-with-setter caaadr (compose-setter set-car! caadr)))
 110 (define caadar (getter-with-setter caadar (compose-setter set-car! cadar)))
 111 (define caaddr (getter-with-setter caaddr (compose-setter set-car! caddr)))
 112 (define cadaar (getter-with-setter cadaar (compose-setter set-car! cdaar)))
 113 (define cadadr (getter-with-setter cadadr (compose-setter set-car! cdadr)))
 114 (define caddar (getter-with-setter caddar (compose-setter set-car! cddar)))
 115 (define cadddr (getter-with-setter cadddr (compose-setter set-car! cdddr)))
 116 (define cdaaar (getter-with-setter cdaaar (compose-setter set-cdr! caaar)))
 117 (define cdaadr (getter-with-setter cdaadr (compose-setter set-cdr! caadr)))
 118 (define cdadar (getter-with-setter cdadar (compose-setter set-cdr! cadar)))
 119 (define cdaddr (getter-with-setter cdaddr (compose-setter set-cdr! caddr)))
 120 (define cddaar (getter-with-setter cddaar (compose-setter set-cdr! cdaar)))
 121 (define cddadr (getter-with-setter cddadr (compose-setter set-cdr! cdadr)))
 122 (define cdddar (getter-with-setter cdddar (compose-setter set-cdr! cddar)))
 123 (define cddddr (getter-with-setter cddddr (compose-setter set-cdr! cdddr)))
 124 (define string-ref (getter-with-setter string-ref string-set!))
 125 (define vector-ref (getter-with-setter vector-ref vector-set!))