A long time ago in a newsgroup far, far away, ...
Andy Gaynor 12 Mar 2000 06:41 UTC
... I posted something resembling what's below.
Works to the best of my knowledge.
Regards, [Ag] Andy Gaynor xxxxxx@quadrix.com
_______________________________________________________________________________
;; Copyright © (c) 2000 by Andy Gaynor
;; A settable lambda is the accessor procedure itself, slightly extended to
;; retain, set, and return its setter procedure upon request.
;;
;; A settable lambda is generated by an expression of the following formats:
;;
;; ;; The typical notation for defining both accessor and setter
;; (settable-lambda ((access ...) value ...)
;; (accessor-body ...)
;; (setter-body ...))
;;
;; ;; The typical notation for defining just the accessor
;; (settable-lambda (access ...) accessor-body ...)
;;
;; ;; The general notation for defining both accessor and setter
;; (settable-lambda accessor-procedure setter-procedure)
;;
;; DEFINE-SETTABLE is an analog to DEFINE mirroring settable-lambda notation:
;;
;; (define-settable (name (access ...) value ...)
;; (accessor-body ...)
;; (setter-body ...))
;;
;; (define-settable (name access ...)
;; accessor-body ...)
;;
;; The function SETTER returns a settable lambda's setter:
;;
;; (setter some-settable-lambda)
;;
;; SETTER is itself a settable lambda which can set a settable-lambda's setter:
;;
;; (set (setter some-settable-lambda) new-setter)
;;
;; DEFINE-SETTER is an analog to DEFINE for setting the setter.
;; The following two are equivalent:
;;
;; (define-setter (some-settable-lambda (access ...) value ...)
;; setter-body ...)
;;
;; (set (setter name) (lambda (access ...)
;; (lambda (value ...)
;; setter-body ...)))
;;
;; SET is an extended SET!-like construct. The following pairs are equivalent:
;;
;; (set variable value)
;; (set! variable value)
;;
;; (set (some-settable-lambda access ...) value ...)
;; (((setter some-settable-lambda) access ...) value ...)
;;
;; Many macro expanders (including syntax-rules and exrename) won't allow
;; something to be improperly defined in terms of itself (in cpp, you can get
;; away with this). Given this, SET! itself can only be redefined if it's
;; defined in terms of some other construct. For maximum extensibility,
;; implementations should define all the advertised constructs in terms of
;; implementation-dependent ones. Many don't, though. And so, in general, an
;; alternate to SET! must be chosen as the interface to setter functionality.
;; Choosing the name of a SET! alternate is hard:
;; set set* set*! set!* set!! setf
;; Of these, I prefer SET and SET!*. But I really want SET!, dammit.
;;
;; Finally, a few familiar operations are defined to be settable-lambdas.
;; These are commented out for now; something unexpected seems to be happening.
;; Help me debug, will you? nth down there seems to work ok.
;; Thanks to Oleg Kiselyov (xxxxxx@pobox.com) for pointing a subtle scoping bug
;; in the original code which resulted in infinite recursion when redefining
;; functions used in this implementation like car and cdr.
(define original-cdr cdr)
(define original-car car)
;; Implementation-dependent.
(define (settable-lambda-error . arguments) (/ 0 0))
;; Hey idiot, limit the scope on this magic value.
(define (setter-magic) setter-magic)
(define-syntax settable-lambda
(syntax-rules ()
;; This could have problems with improper (access ...).
;; Broken up into () and (access-1 . access-rest).
;;((settable-lambda ((access-1 ...) . value-rest) accessor-body setter-body)
;; (settable-lambda (lambda (access-1 ...) . accessor-body)
;; (lambda (access-1 ...) (lambda value-rest . setter-body))))
((settable-lambda (() . value-rest) accessor-body setter-body)
(settable-lambda (lambda () . accessor-body)
(lambda () (lambda value-rest . setter-body))))
((settable-lambda ((access-1 . access-rest) . value-rest) accessor-body setter-body)
(settable-lambda (lambda (access-1 . access-rest) . accessor-body)
(lambda (access-1 . access-rest) (lambda value-rest . setter-body))))
((settable-lambda accessor-value setter-value)
(letrec ((accessor accessor-value) (setter setter-value))
(lambda arguments
(cond ((null? arguments)
(accessor))
((not (eq? (original-car arguments) (setter-magic)))
(apply accessor arguments))
((null? (original-cdr arguments))
setter)
((null? (original-cdr (original-cdr arguments)))
(set! setter (cadr arguments)))
(else
(settable-lambda-error "Setter magic error"))))))
;; This could have problems with improper (access ...).
;; Broken up into () and (access-1 . access-rest).
;;((settable-lambda (access ...) . accessor-body)
;; (settable-lambda (lambda (access ...) . accessor-body) #f))
((settable-lambda () . accessor-body)
(settable-lambda (lambda () . accessor-body) #f))
((settable-lambda (access-1 . access-rest) . accessor-body)
(settable-lambda (lambda (access-1 . access-rest) . accessor-body) #f))))
(define-syntax define-settable
(syntax-rules ()
((define-settable (name . stuff-1) . stuff-2)
(define name (settable-lambda stuff-1 . stuff-2)))))
(define-syntax define-setter
(syntax-rules ()
((define-setter (name access-rest . value-rest) . body)
(name (setter-magic) (lambda access-rest (lambda value-rest . body))))))
(define-settable (setter (settable) new-setter)
((settable (setter-magic)))
((settable (setter-magic) new-setter)))
(define-syntax set
(syntax-rules ()
((set (settable . access-rest) . value-rest)
(((setter settable) . access-rest) . value-rest))
((set variable value)
(set! variable value))))
;; (define car (let ((original-car car))
;; (settable-lambda ((x) value) ((original-car x)) ((set-car! x value)))))
;; (define cdr (let ((original-cdr cdr))
;; (settable-lambda ((x) value) ((original-cdr x)) ((set-cdr! x value)))))
;;
;; Form Values
;;
;; (define x (list 'a 'b 'c))
;; (car x) a
;; (set (car x) 'aa)
;; x (aa b c)
;; (set (cdr x) '())
;; x (aa)
;; (define-settable (nth (x i) value)
;; ((cond ((list? x) (list-ref x i))
;; ((vector? x) (vector-ref x i))
;; ((string? x) (string-ref x i))))
;; ((cond ((list? x) (set-car! (list-tail x i) value))
;; ((vector? x) (vector-set! x i value))
;; ((string? x) (string-set! x i value)))))
;; (define *red* 0)
;; (define *green* 0)
;; (define *blue* 0)
;;
;; (define-settable (color () r g b)
;; ((values *red* *green* *blue*))
;; ((set *red* r)
;; (set *green* g)
;; (set *blue* b)))
;;
;; Form Values
;;
;; (color) 0 0 0
;; (set (color) 1 2 3)
;; (color) 1 2 3
;; The same as above, but hiding *red*, *green*, and *blue*.
;;
;; (define color
;; (let ((red 0)
;; (green 0)
;; (blue 0))
;; (settable-lambda (() r g b)
;; ((values red green blue))
;; ((set red r)
;; (set green g)
;; (set blue b)))))
;;
;; Form Values
;;
;; (color) 0 0 0
;; (set (color) 1 2 3)
;; (color) 1 2 3