This is the mail archive of the guile@cygnus.com mailing list for the guile project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
The previous version had a bug (copy-proc should have been a macro instead of a memoizing macro). Here's an improved version. (The setter argument convention has been changed to (SETTER A1 ... V)). Note that this implementation is only meant to clearify the interface. ;;; installed-scm-file ;;;; Copyright (C) 1998 Free Software Foundation, Inc. ;;;; ;;;; This program 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 2, or (at your option) ;;;; any later version. ;;;; ;;;; This program 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 this software; see the file COPYING. If not, write to ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;; (define-module (ice-9 setters)) (define-public (make-procedure-with-setter getter setter) (let ((proc (copy-procedure getter (the-environment)))) (set-procedure-property! proc '<procedure-with-setter> #t) proc)) (define-public (procedure-with-setter? proc) (procedure-property '<procedure-with-setter>)) (define-public (getter proc) (local-eval 'getter (procedure-environment proc))) (define-public (setter proc) (local-eval 'setter (procedure-environment proc))) (if (not (defined? 'internal-set!)) (define internal-set! set!)) (define-public set! (procedure->memoizing-macro (lambda (exp env) (if (pair? (cadr exp)) `((setter ,(caadr exp)) ,@(cdadr exp) ,(caddr exp)) `(internal-set! ,@(cdr exp)))))) (define (copy-procedure original . rest) (local-eval (let* ((arity (procedure-property original 'arity)) (formals (list-tail '(x y z u v w a b c d) (- 10 (car arity))))) (cond ((and (not (caddr arity)) (zero? (cadr arity))) `(lambda ,formals (,original ,@formals))) ((null? formals) `(lambda args (apply ,original args))) (else (let ((rest-formals (append formals '()))) (set-cdr! (last-pair rest-formals) 'rest) `(lambda ,rest-formals (apply ,original ,@formals rest)))))) (if (null? rest) (procedure-environment original) (car rest))))