suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SRFI 57 for PLT v300.

Browse Source 
svn: r1181
This commit is contained in:
Chongkai Zhu 2005-10-30 23:33:31 +00:00
parent 739c7bce07
commit 3a30e59db2
3 changed files with 386 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/srfi/57.ss Normal file
View File

@ -0,0 +1,4 @@
;; module loader for SRFI-57
(module |57| mzscheme
(require (lib "records.ss" "srfi" "57"))
(provide (all-from (lib "records.ss" "srfi" "57"))))

307
collects/srfi/57/records.ss Normal file
View File

@ -0,0 +1,307 @@
; SRFI 57
; Zhu Chongkai mrmathematica@yahoo.com
; Based on original author's syntax-case implementation
(module records mzscheme
(provide define-record-type
define-record-scheme
record-update
record-update!
record-compose
show)
(require (prefix s9: (lib "9.ss" "srfi")))
(require-for-syntax (prefix s1: (lib "1.ss" "srfi")))
(require-for-syntax "registry.ss")
(define-syntax define-record-type
(syntax-rules ()
((define-record-type . body)
(parse-declaration #f . body))))
(define-syntax define-record-scheme
(syntax-rules ()
((define-record-scheme . body)
(parse-declaration #t . body))))
(define-syntax parse-declaration
(syntax-rules ()
((parse-declaration is-scheme? (name super ...) (constructor pos-label ...) predicate field-clause ...)
(build-record (constructor pos-label ...) #f (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor predicate field-clause ...)
(build-record (constructor) #t (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor-clause)
(parse-declaration is-scheme? (name super ...) constructor-clause #f))
((parse-declaration is-scheme? (name super ...))
(parse-declaration is-scheme? (name super ...) #f #f))
((parse-declaration is-scheme? name . rest)
(parse-declaration is-scheme? (name) . rest))))
(define-syntax record-update!
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(with-syntax (((setter ...)
(map (lambda (label)
(lookup-setter #`name label))
(syntax->list #`(label ...)))))
#`(let ((r record))
(setter r exp)
...
r))))))
(define-syntax record-update
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(if (lookup-scheme? #`name)
(with-syntax ((copier (lookup-copier #`name)))
#`(let ((new (copier record)))
(record-update! new name (label exp) ...)))
#`(record-compose (name record) (name (label exp) ...)))))))
(define-syntax record-compose
(lambda (stx)
(syntax-case stx ()
((record-compose (export-name (label exp) ...))
#`(export-name (label exp) ...))
((record-compose (import-name record) import ... (export-name (label exp) ...))
(with-syntax
(((copy-label ...)
(s1:lset-intersection free-identifier=?
(lookup-labels #`export-name)
(s1:lset-difference free-identifier=?
(lookup-labels #`import-name)
(syntax->list #`(label ...))))))
(with-syntax (((getter ...)
(s1:map (lambda (label)
(lookup-getter #`import-name label))
(syntax->list #`(copy-label ...)))))
#`(let ((r record))
(record-compose import ...
(export-name (copy-label (getter r))
...
(label exp)
...)))))))))
(define-syntax build-record
(let ()
(define (build-record stx)
(syntax-case stx ()
((build-record (constructor pos-label ...)
default-order?
(super ...)
((field-label . accessors) ...)
name
predicate
is-scheme?)
(with-syntax
(((label ...)
(s1:delete-duplicates (s1:fold-right append
(syntax->list #`(pos-label ... field-label ...))
(map lookup-labels
(syntax->list #`(super ...))))
free-identifier=?))
((super ...)
(s1:delete-duplicates (s1:fold-right append
'()
(map lookup-supers
(syntax->list #`(super ...))))
free-identifier=?)))
(with-syntax
(((pos-label ...)
(if (syntax-e #`default-order?)
#`(label ...)
#`(pos-label ...)))
(((field-label getter setter) ...)
(append (map augment-field
(syntax->list #`((field-label . accessors) ...)))
(map (lambda (label)
(maybe-generate #`name `(,label getter setter)))
(s1:lset-difference free-identifier=?
(syntax->list #`(label ...))
(syntax->list #`(field-label ...)))))))
(with-syntax ((supers #`(super ...))
((pos-temp ...) (generate-temporaries #`(pos-label ...)))
((constructor predicate maker copier)
(maybe-generate #`name `(,#`constructor ,#`predicate maker copier))))
(begin
(register #`name (make-entry #`name
(syntax-e #`is-scheme?)
#`predicate
(syntax->list #`(super ... name))
(syntax->list #`(label ...))
(syntax->list #`(pos-label ...))
(map syntax->list
(syntax->list #`((field-label getter setter) ...)))
#`copier))
(if (syntax-e #`is-scheme?)
#`(begin
(define-generic (predicate x) (lambda (x) #f))
(define-generic (getter x))
...
(define-generic (setter x v))
...
(define-generic (copier x)))
#`(begin
(s9:define-record-type internal-name
(maker field-label ...)
predicate
(field-label getter setter) ...)
(define constructor
(lambda (pos-temp ...)
(populate maker (field-label ...) (pos-label pos-temp) ...)))
(extend-predicates supers predicate)
(extend-accessors supers field-label predicate getter setter)
...
(define (copier x)
(maker (getter x) ...))
(extend-copiers supers copier predicate)
(define-method (show (r predicate))
(list 'name
(list 'field-label (getter r))
...))
(define-syntax name
(syntax-rules ()
((name . bindings) (populate maker (field-label ...) . bindings))))
))))))))) ; build-record
(define (maybe-generate context maybe-identifiers)
(map (lambda (elem)
(if (identifier? elem)
elem
(datum->syntax-object context (if (symbol? elem)
(gensym elem)
(gensym)))))
maybe-identifiers))
(define (augment-field clause)
(syntax-case clause ()
((label) `(,#`label ,@(maybe-generate #`label `( getter setter))))
((label getter) `(,#`label ,@(maybe-generate #`label `(,#`getter setter))))
((label getter setter) `(,#`label ,@(maybe-generate #`label `(,#`getter ,#`setter))))))
build-record))
(define-syntax extend-predicates
(lambda (stx)
(syntax-case stx ()
((extend-predicates (super ...) new-type)
(with-syntax (((predicate ...) (map lookup-predicate
(syntax->list #`(super ...)))))
#`(begin
(define-method predicate (new-type) (x) any?)
...))))))
(define-syntax extend-copiers
(lambda (stx)
(syntax-case stx ()
((extend-copiers (super ...) copy new-type)
(with-syntax (((copier ...) (map lookup-copier
(syntax->list #`(super ...)))))
#`(begin
(define-method copier (new-type) (x) copy)
...))))))
(define-syntax extend-accessors
(lambda (stx)
(syntax-case stx ()
((extend-accessors (super ...) label new-type selector modifier)
(with-syntax (((getter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-getter super #`label))
(syntax->list #`(super ...)))))
((setter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-setter super #`label))
(syntax->list #`(super ...))))))
#`(begin
(define-method getter (new-type) (x) selector)
...
(define-method setter (new-type any?) (x v) modifier)
...))))))
(define-syntax populate
(lambda (stx)
(define (order ordering bindings default)
(if (null? (s1:lset-difference free-identifier=?
(map car bindings)
ordering))
(map (lambda (label)
(cond ((s1:assoc label bindings free-identifier=?) => (lambda (x) x))
(else `(,label ,default))))
ordering)
(raise-syntax-error #f "Illegal labels in" stx)))
(syntax-case stx ()
((populate maker labels . bindings)
(with-syntax ((((label exp) ...) (order (syntax->list #`labels)
(map syntax->list
(syntax->list #'bindings))
#`'<undefined>)))
#`(maker exp ...))))))
; Simple generic functions suitable for our disjoint base record types:
(define-syntax define-generic
(syntax-rules ()
((define-generic (name arg ...))
(define-generic (name arg ...)
(lambda (arg ...) (error "Inapplicable method:" 'name
"Arguments:" (show arg) ... ))))
((define-generic (name arg ...) proc)
(define name (make-generic (arg ...) proc)))))
(define-syntax define-method
(syntax-rules ()
((define-method (generic (arg pred?) ...) . body)
(define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body)))
((define-method generic (pred? ...) (arg ...) procedure)
(let ((next ((generic) 'get-proc))
(proc procedure))
(((generic) 'set-proc)
(lambda (arg ...)
(if (and (pred? arg) ...)
(proc arg ...)
(next arg ...))))))))
(define-syntax make-generic
(syntax-rules ()
((make-generic (arg arg+ ...) default-proc)
(let ((proc default-proc))
(case-lambda
((arg arg+ ...)
(proc arg arg+ ...))
(()
(lambda (msg)
(case msg
((get-proc) proc)
((set-proc) (lambda (new)
(set! proc new)))))))))))
(define-generic (show x)
(lambda (x) x))
(define (any? x) #t)
) ; records

75
collects/srfi/57/registry.ss Normal file
View File

@ -0,0 +1,75 @@
(module registry mzscheme
(provide register
make-entry
lookup-entry
lookup-scheme?
lookup-getter
lookup-setter
lookup-labels
lookup-supers
lookup-copier
lookup-predicate)
(require (prefix s1: (lib "1.ss" "srfi")))
(define reg '())
(define (make-entry name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier)
(vector name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier))
(define (entry.name entry) (vector-ref entry 0))
(define (entry.is-scheme? entry) (vector-ref entry 1))
(define (entry.predicate entry) (vector-ref entry 2))
(define (entry.supers entry) (vector-ref entry 3))
(define (entry.labels entry) (vector-ref entry 4))
(define (entry.pos-labels entry) (vector-ref entry 5))
(define (entry.fields entry) (vector-ref entry 6))
(define (entry.copier entry) (vector-ref entry 7))
(define (register name entry)
(cond ((s1:assoc name reg free-identifier=?)
=> (lambda (pair)
(set-cdr! pair entry)))
(else
(set! reg (cons (cons name entry)
reg)))))
(define (lookup-entry name)
(s1:assoc name reg free-identifier=?))
(define (lookup-getter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
free-identifier=?)
=> cadr)
(else #f)))
(define (lookup-setter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
free-identifier=?)
=> caddr)
(else #f)))
(define (lookup-scheme? name) (entry.is-scheme? (cdr (lookup-entry name))))
(define (lookup-labels name) (entry.labels (cdr (lookup-entry name))))
(define (lookup-supers name) (entry.supers (cdr (lookup-entry name))))
(define (lookup-copier name) (entry.copier (cdr (lookup-entry name))))
(define (lookup-predicate name) (entry.predicate (cdr (lookup-entry name))))
) ; registry