Re: set! prototype implementation

[Mikael Djurfeldt <mdj@nada.kth.se>]

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))))