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] |
Of course the real implementation will be more efficient. ;;; 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-proc getter))) (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)) ,(caddr exp) ,@(cdadr exp)) `(internal-set! ,@(cdr exp)))))) (define copy-proc (procedure->memoizing-macro (lambda (exp env) (let* ((original (local-eval (cadr exp) env)) (arity (procedure-property original 'arity)) (names (list-tail '(x y z u v w a b c d) (- 10 (car arity)))) (formals names)) (cond ((not (caddr arity)) `(lambda ,formals (,original ,@formals))) ((null? formals) `(lambda args (apply ,original args))) (else (set! formals (append formals '())) (set-cdr! (last-pair formals) 'rest) `(lambda ,formals (apply ,original ,@names rest))))))))