62 lines
1.9 KiB
Scheme
62 lines
1.9 KiB
Scheme
|
; Copyright (c) 1993-1999 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 (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))))))
|