1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Syntax used by the compiler
; Subrecords
;
; SUPER is the name of the existing record
; SUB is the name of the subrecord
; SLOT is the name of the slot to use in the existing sturcture
; STUFF is the usual stuff from DEFINE-RECORD-TYPE
(define-syntax define-subrecord
(lambda (form rename compare)
(let ((super (cadr form))
(sub (caddr form))
(slot (cadddr form))
(stuff (cddddr form)))
(let ((access-names (map (lambda (spec)
(if (pair? spec) (car spec) spec))
(append (car stuff) (cadr stuff))))
(set-names (append (filter-map (lambda (spec)
(if (pair? spec) (car spec) #f))
(car stuff))
(map (lambda (spec)
(if (pair? spec) (car spec) spec))
(cadr stuff)))))
`(begin (,(rename 'define-record-type) ,sub . ,stuff)
,@(map (lambda (name)
`(define ,(concatenate-symbol super '- name)
(lambda (v)
(,(concatenate-symbol sub '- name)
(,slot v)))))
access-names)
,@(map (lambda (name)
`(define ,(concatenate-symbol 'set- super '- name '!)
(lambda (v n)
(,(concatenate-symbol 'set- sub '- name '!)
(,slot v)
n))))
set-names))))))
;(define-syntax define-simple-record-type
; (lambda (form rename compare)
; (let ((name (cadr form))
; (slots (cddr form)))
; `(begin (define-record-type ,name ,slots ())
; (define ,(concatenate-symbol 'make- name)
; ,(concatenate-symbol name '- 'maker))))))
; Nothing actually local about it...
(define-syntax define-local-syntax
(lambda (form rename compare)
(let ((pattern (cadr form))
(body (cddr form)))
`(,(rename 'define-syntax) ,(car pattern)
(,(rename 'lambda) (form rename compare)
(,(rename 'destructure) ((,(cdr pattern)
(,(rename 'cdr) form)))
. ,body))))))
|
