stk/Lib/extset.stk

;;;;
;;;; extset.stk 			-- provide Dylan like setters
;;;;
;;;; Copyright <20> 1997-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 30-May-1997 15:29
;;;; Last file update:  3-Sep-1999 19:51 (eg)


(when (provided? "extset") (error "Extended set! already loaded."))

(select-module STk)


(define (extended-name->scheme-name l)
  (cond
   ((and (list? l) (= (length l) 2) (eq? (car l) 'setter))
       		        (string->symbol (format #f "the setter of ~A" (cadr l))))
   ((symbol? l)		l)
   (else    		(error "bad Scheme name ~S" l))))


(define-macro (setter var)
  (let ((x (extended-name->scheme-name `(setter ,var))))
    `(if (symbol-bound? ',x (module-environment (current-module)))
	 ,x
	 (error "Setter of ~s is undefined" ',var))))


;;
;; Redefine  DEFINE and SET! 
;;

(let ((%define define)		; %define is the Scheme define
      (%set!   set!))		; %set! is the scheme set!
  
  (define-macro (dylan-define var . val)
    (when (null? val) 
      (error "define: no value provided for ~A" var))
    (if (and (pair? var) (eqv? (car var) 'setter))
	`(,%define ,(extended-name->scheme-name var) ,@val)
	`(,%define ,var ,@val)))

  (define-macro (dylan-set! var val)
    (if (list? var)
	`(,(extended-name->scheme-name `(setter ,(car var))) ,@(cdr var) ,val)
	`(,%set! ,(extended-name->scheme-name var) ,val)))

  ;; Set the standard set! and define to the extended equivalents
  (set! set!   dylan-set!)
  (set! define dylan-define))


;;
;; SET! and DEFINE are redefined in the toplevel module first and
;; in the STklos module after that. Work is done 2 times because
;; users which don't want to see modules must have the new 
;; definition in the toplevel module (even if they import STklos, 
;; the current module for them is STk which will be looked at before 
;; STklos). Furthermore, doing it only in STk is not suficient 
;; since STklos import Scheme first, we should see the standard 
;; bindings instead of the new ones. 
;;

(with-module STklos
   (define set!   (with-module STk set!))
   (define define (with-module STk define)))

(provide "extset")