672910f27b
I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w <file>". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 <sha1>".
293 lines
9.1 KiB
Racket
293 lines
9.1 KiB
Racket
#!r6rs
|
|
|
|
;; Implementation of explicit-naming layer for R6RS Records
|
|
|
|
;; Based on the SRFI implementation:
|
|
; Copyright (C) Michael Sperber (2005). All Rights Reserved.
|
|
;
|
|
; Permission is hereby granted, free of charge, to any person
|
|
; obtaining a copy of this software and associated documentation files
|
|
; (the "Software"), to deal in the Software without restriction,
|
|
; including without limitation the rights to use, copy, modify, merge,
|
|
; publish, distribute, sublicense, and/or sell copies of the Software,
|
|
; and to permit persons to whom the Software is furnished to do so,
|
|
; subject to the following conditions:
|
|
;
|
|
; The above copyright notice and this permission notice shall be
|
|
; included in all copies or substantial portions of the Software.
|
|
;
|
|
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
; SOFTWARE.
|
|
|
|
(library (r6rs private records-explicit)
|
|
(export define-record-type
|
|
record-type-descriptor
|
|
record-constructor-descriptor
|
|
fields mutable immutable parent parent-rtd protocol
|
|
sealed opaque nongenerative)
|
|
(import (for (rnrs base) run expand)
|
|
(rnrs records procedural)
|
|
(for (rnrs syntax-case) expand))
|
|
|
|
(define-syntax define-aux
|
|
(syntax-rules ()
|
|
[(_ id) (define-syntax id (syntax-rules ()))]
|
|
[(_ id ...) (begin (define-aux id) ...)]))
|
|
|
|
(define-aux
|
|
fields mutable immutable parent parent-rtd protocol sealed opaque nongenerative)
|
|
|
|
;; ASSQ at the syntax level
|
|
(define-syntax define-alist-extractor
|
|
(syntax-rules ()
|
|
((define-alist-extractor ?name ?name/cps ?tag ?default)
|
|
(begin
|
|
|
|
(define-syntax ?name/cps
|
|
(syntax-rules (?tag)
|
|
((?name/cps () ?k . ?rands)
|
|
(?k ?default . ?rands))
|
|
((?name/cps ((?tag ?val) . ?rest) ?k . ?rands)
|
|
(?k ?val . ?rands))
|
|
((?name/cps ((?another-tag . ?vals) . ?rest) ?k . ?rands)
|
|
(?name/cps ?rest ?k . ?rands))))
|
|
(define-syntax ?name
|
|
(syntax-rules (?tag)
|
|
((?name ())
|
|
?default)
|
|
((?name ((?tag ?val) . ?rest))
|
|
?val)
|
|
((?name ((?another-tag . ?vals) . ?rest))
|
|
(?name ?rest))))))))
|
|
|
|
(define-syntax extract-parent/sel
|
|
(syntax-rules (parent parent-rtd)
|
|
((_ () ?sel) #f)
|
|
((_ ((parent ?val) . ?rest) ?sel)
|
|
(?sel (record-type-descriptor ?val)
|
|
(record-constructor-descriptor ?val)))
|
|
((_ ((parent-rtd ?rtd ?cons) . ?rest) ?sel)
|
|
(?sel ?rtd ?cons))
|
|
((_ ((?another-tag . ?vals) . ?rest) ?sel)
|
|
(extract-parent/sel ?rest ?sel))))
|
|
(define-syntax sel-record-type-descriptor
|
|
(syntax-rules ()
|
|
[(_ ?rtd ?cons) ?rtd]))
|
|
(define-syntax sel-record-constructor-descriptor
|
|
(syntax-rules ()
|
|
[(_ ?rtd ?cons) ?cons]))
|
|
|
|
(define-alist-extractor extract-sealed extract-sealed/cps sealed #f)
|
|
(define-alist-extractor extract-opaque extract-opaque/cps opaque #f)
|
|
(define-alist-extractor extract-protocol extract-protocol/cps
|
|
protocol #f)
|
|
(define-alist-extractor extract-nongenerative extract-nongenerative/cps nongenerative #f)
|
|
|
|
(define-alist-extractor extract-record-name extract-record-name/cps record-name cant-happen)
|
|
(define-alist-extractor extract-constructor-name extract-constructor-name/cps
|
|
constructor-name cant-happen)
|
|
(define-alist-extractor extract-predicate-name extract-predicate-name/cps
|
|
predicate-name cant-happen)
|
|
|
|
|
|
(define-syntax define-record-type
|
|
(syntax-rules ()
|
|
((define-record-type (?record-name ?constructor-name ?predicate-name)
|
|
?clause ...)
|
|
(define-record-type-1
|
|
((record-name ?record-name) ; prop alist
|
|
(constructor-name ?constructor-name)
|
|
(predicate-name ?predicate-name))
|
|
() ; fields
|
|
?clause ...))))
|
|
|
|
(define-syntax define-record-type-1
|
|
(syntax-rules (parent parent-rtd protocol sealed nongenerative opaque fields mutable immutable)
|
|
;; find PARENT clause
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(parent ?parent)
|
|
?clause ...)
|
|
(define-record-type-1 ((parent ?parent) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(parent-rtd ?parent ?cons)
|
|
?clause ...)
|
|
(define-record-type-1 ((parent-rtd ?parent ?cons) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
|
|
;; find PROTOCOL clause
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(protocol ?protocol)
|
|
?clause ...)
|
|
(define-record-type-1 ((protocol ?protocol) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
|
|
;; find SEALED clause
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(sealed #t)
|
|
?clause ...)
|
|
(define-record-type-1 ((sealed #t) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(sealed #f)
|
|
?clause ...)
|
|
(define-record-type-1 ((sealed #f) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
|
|
;; find OPAQUE clause
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(opaque #t)
|
|
?clause ...)
|
|
(define-record-type-1 ((opaque #t) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(opaque #f)
|
|
?clause ...)
|
|
(define-record-type-1 ((opaque #f) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
|
|
;; parse FIELDS clause
|
|
|
|
;; base case
|
|
((define-record-type-1 ?props
|
|
(?field-spec ...)
|
|
(fields)
|
|
?clause ...)
|
|
(define-record-type-1 ?props
|
|
(?field-spec ...)
|
|
?clause ...))
|
|
|
|
;; complete spec
|
|
((define-record-type-1 ?props
|
|
(?field-spec ...)
|
|
(fields (immutable ?field-name ?accessor) ?rest ...)
|
|
?clause ...)
|
|
(define-record-type-1 ?props
|
|
(?field-spec ... (immutable ?field-name (?accessor)))
|
|
(fields ?rest ...)
|
|
?clause ...))
|
|
|
|
((define-record-type-1 ?props
|
|
(?field-spec ...)
|
|
(fields (mutable ?field-name ?accessor ?mutator) ?rest ...)
|
|
?clause ...)
|
|
(define-record-type-1 ?props
|
|
(?field-spec ... (mutable ?field-name (?accessor ?mutator)))
|
|
(fields ?rest ...)
|
|
?clause ...))
|
|
|
|
;; find NONGENERATIVE clause
|
|
((define-record-type-1 ?props
|
|
?field-specs
|
|
(nongenerative ?uid)
|
|
?clause ...)
|
|
(define-record-type-1 ((nongenerative '?uid) . ?props)
|
|
?field-specs
|
|
?clause ...))
|
|
|
|
;; generate code
|
|
((define-record-type-1 ?props
|
|
((?mutability ?field-name ?procs) ...))
|
|
|
|
(begin
|
|
;; where we need LETREC* semantics if this is to work internally
|
|
|
|
(define $rtd
|
|
(make-record-type-descriptor (extract-record-name/cps ?props quote)
|
|
(extract-parent/sel ?props sel-record-type-descriptor)
|
|
(extract-nongenerative ?props)
|
|
(extract-sealed ?props)
|
|
(extract-opaque ?props)
|
|
'#((?mutability ?field-name) ...)))
|
|
|
|
(define $constructor-descriptor
|
|
(make-record-constructor-descriptor
|
|
$rtd
|
|
(extract-parent/sel ?props sel-record-constructor-descriptor)
|
|
(extract-protocol ?props)))
|
|
|
|
(extract-record-name/cps
|
|
?props
|
|
define-record-type-name $rtd $constructor-descriptor)
|
|
|
|
(extract-constructor-name/cps
|
|
?props
|
|
define
|
|
(record-constructor $constructor-descriptor))
|
|
|
|
(extract-predicate-name/cps ?props
|
|
define (record-predicate $rtd))
|
|
|
|
(define-record-fields $rtd
|
|
0 (?field-name ?procs) ...)))))
|
|
|
|
(define-syntax define-record-type-name
|
|
(syntax-rules ()
|
|
((define-record-type-name ?name ?rtd ?constructor-descriptor)
|
|
(define-syntax ?name
|
|
(make-variable-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (descriptor constructor-descriptor set!)
|
|
(?name (identifier? #'?name) #'?rtd)
|
|
((set! ?name . rest) (syntax-violation #f "cannot mutate record-type descriptor binding" stx #'name))
|
|
((?name descriptor) #'?rtd)
|
|
((?name constructor-descriptor) #'?constructor-descriptor))))))))
|
|
|
|
(define-syntax no-record-type
|
|
(syntax-rules (descriptor constructor-descriptor)
|
|
((?name descriptor) #f)
|
|
((?name constructor-descriptor) #f)))
|
|
|
|
(define-syntax record-type-descriptor
|
|
(syntax-rules ()
|
|
((record-type-descriptor ?record-type)
|
|
(?record-type descriptor))))
|
|
|
|
(define-syntax record-constructor-descriptor
|
|
(syntax-rules ()
|
|
((record-constructor-descriptor ?record-type)
|
|
(?record-type constructor-descriptor))))
|
|
|
|
(define-syntax define-record-fields
|
|
(syntax-rules ()
|
|
((define-record-fields ?rtd ?index)
|
|
(begin))
|
|
((define-record-fields ?rtd ?index (?field-name ?procs) . ?rest)
|
|
(begin
|
|
(define-record-field ?rtd ?field-name ?index ?procs)
|
|
(define-record-fields ?rtd (+ 1 ?index) . ?rest)))))
|
|
|
|
(define-syntax define-record-field
|
|
(syntax-rules ()
|
|
((define-record-field ?rtd
|
|
?field-name ?index (?accessor-name))
|
|
(define ?accessor-name
|
|
(record-accessor ?rtd ?index)))
|
|
((define-record-field ?rtd
|
|
?field-name ?index (?accessor-name ?mutator-name))
|
|
(begin
|
|
(define ?accessor-name
|
|
(record-accessor ?rtd ?index))
|
|
(define ?mutator-name
|
|
(record-mutator ?rtd ?index)))))))
|