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

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

This page is part of the web mail archives of SRFI 17 from before July 7th, 2015. The new archives for SRFI 17 contain all messages, not just those from before July 7th, 2015.



... 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