[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

A long time ago in a newsgroup far, far away, ...



... I posted something resembling what's below.
Works to the best of my knowledge.

Regards, [Ag]   Andy Gaynor   silver@xxxxxxxxxxx
_______________________________________________________________________________

;; 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 (oleg@xxxxxxxxx) 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