scsh-0.6/ps-compiler/util/syntax.scm

62 lines
1.9 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; 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))))))