80 lines
2.6 KiB
Raw Normal View History

1998-04-10 06:59:06 -04:00
;;;; extset.stk -- provide Dylan like setters
1999-09-05 07:16:41 -04:00
;;;; Copyright <20> 1997-1999 Erick Gallesio - I3S-CNRS/ESSI <>
1998-04-10 06:59:06 -04:00
1999-09-05 07:16:41 -04:00
;;;; 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.
1998-04-10 06:59:06 -04:00
;;;; Author: Erick Gallesio []
;;;; Creation date: 30-May-1997 15:29
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:51 (eg)
1998-04-10 06:59:06 -04:00
(when (provided? "extset") (error "Extended set! already loaded."))
(select-module STk)
(define (extended-name->scheme-name l)
((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)))
(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")