1; Part of Scheme 48 1.9. See file COPYING for notices and license. 2 3; Authors: Richard Kelsey, Jonathan Rees 4 5(define-syntax set! 6 (syntax-rules () 7 ((set! (?e0 ?e1 ...) ?v) 8 ((setter ?e0) ?e1 ... ?v)) 9 ((set! ?i ?v) 10 (scheme-set! ?i ?v)))) 11 12(define (setter proc) 13 (let ((probe (assv proc setters))) 14 (if probe 15 (cdr probe) 16 (assertion-violation 'setter "No setter found" proc)))) 17 18(define (set-setter! proc setter) 19 (let ((probe (assv proc setters))) 20 (if probe 21 (set-cdr! probe setter) 22 (scheme-set! setters 23 (cons (cons proc setter) 24 setters))) 25 (unspecific))) 26 27(define (car-setter proc) 28 (lambda (p v) 29 (set-car! (proc p) v))) 30 31(define (cdr-setter proc) 32 (lambda (p v) 33 (set-cdr! (proc p) v))) 34 35(define setters 36 (list (cons setter set-setter!) 37 (cons vector-ref vector-set!) 38 (cons string-ref string-set!) 39 (cons car set-car!) 40 (cons cdr set-cdr!) 41 42 (cons caar (car-setter car)) 43 (cons cdar (cdr-setter car)) 44 (cons cadr (car-setter cdr)) 45 (cons cddr (cdr-setter cdr)) 46 47 (cons caaar (car-setter caar)) 48 (cons cdaar (cdr-setter caar)) 49 (cons cadar (car-setter cdar)) 50 (cons cddar (cdr-setter cdar)) 51 (cons caadr (car-setter cadr)) 52 (cons cdadr (cdr-setter cadr)) 53 (cons caddr (car-setter cddr)) 54 (cons cdddr (cdr-setter cddr)) 55 56 (cons caaaar (car-setter caaar)) 57 (cons cdaaar (cdr-setter caaar)) 58 (cons cadaar (car-setter cdaar)) 59 (cons cddaar (cdr-setter cdaar)) 60 (cons caadar (car-setter cadar)) 61 (cons cdadar (cdr-setter cadar)) 62 (cons caddar (car-setter cddar)) 63 (cons cdddar (cdr-setter cddar)) 64 (cons caaadr (car-setter caadr)) 65 (cons cdaadr (cdr-setter caadr)) 66 (cons cadadr (car-setter cdadr)) 67 (cons cddadr (cdr-setter cdadr)) 68 (cons caaddr (car-setter caddr)) 69 (cons cdaddr (cdr-setter caddr)) 70 (cons cadddr (car-setter cdddr)) 71 (cons cddddr (cdr-setter cdddr)))) 72 73