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