set! prototype implementation

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

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