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