This page is part of the web mail archives of SRFI 57 from before July 7th, 2015. The new archives for SRFI 57 contain all messages, not just those from before July 7th, 2015.
Andre
;============================================================================================
; DEPENDENCIES:
;
; Andre van Tonder, 2005.
;
; This section contains an implementation of SRFI-9 and the
; necessary procedures from SRFI-1. May be omitted if these
; SRFIs are already available.
;
;============================================================================================
; Only the necessary procedures adapted from the SRFI-1 reference
; implementation. If you have SRFI-1, this may be omitted. Here I
; didn't bother with optional arguments since only fixed-arity
; versions are needed.
(module srfi-1 (s1:assoc
s1:lset-intersection
s1:lset-difference
s1:delete-duplicates
s1:fold-right
s1:filter
s1:member)
(define (find pred list)
(cond ((find-tail pred list) => car)
(else #f)))
(define (s1:member x lis =)
(find-tail (lambda (y) (= x y)) lis))
(define (find-tail pred list)
(let lp ((list list))
(and (not (null-list? list))
(if (pred (car list)) list
(lp (cdr list))))))
(define (s1:assoc x lis =)
(find (lambda (entry) (= x (car entry))) lis))
(define (s1:lset-intersection = lis1 . lists)
(let ((lists (delete lis1 lists eq?)))
(cond ((any null-list? lists) '())
((null? lists) lis1)
(else (s1:filter (lambda (x)
(every (lambda (lis) (s1:member x lis =))
lists))
lis1)))))
(define (s1:lset-difference = lis1 . lists)
(let ((lists (s1:filter pair? lists)))
(cond ((null? lists) lis1)
((memq lis1 lists) '())
(else (s1:filter (lambda (x)
(every (lambda (lis) (not (s1:member x lis =)))
lists))
lis1)))))
(define (every pred list)
(let lp ((list list))
(or (not (pair? list))
(and (pred (car list))
(lp (cdr list))))))
(define (delete x lis =)
(s1:filter (lambda (y) (not (= x y))) lis))
(define (any pred lis1)
(and (not (null-list? lis1))
(let lp ((head (car lis1)) (tail (cdr lis1)))
(if (null-list? tail)
(pred head)
(or (pred head) (lp (car tail) (cdr tail)))))))
(define (s1:delete-duplicates lis elt=)
(let recur ((lis lis))
(if (null-list? lis) lis
(let* ((x (car lis))
(tail (cdr lis))
(new-tail (recur (delete x tail elt=))))
(if (eq? tail new-tail) lis (cons x new-tail))))))
(define (s1:fold-right kons knil lis1)
(let recur ((lis lis1))
(if (null-list? lis) knil
(let ((head (car lis)))
(kons head (recur (cdr lis)))))))
(define null-list? null?)
(define (s1:filter pred lis)
(let recur ((lis lis))
(if (null-list? lis) lis
(let ((head (car lis))
(tail (cdr lis)))
(if (pred head)
(let ((new-tail (recur tail)))
(if (eq? tail new-tail) lis
(cons head new-tail)))
(recur tail))))))
)
;======================================================================================
; SRFI-9 implementation, based on implementation by Felix Winkelmann.
; If you have SRFI-9, this may be omitted.
(module srfi-9 (s9:define-record-type)
(import srfi-1)
(define-syntax (s9:define-record-type x)
(syntax-case x ()
((_ t (conser vars ...) pred slots ...)
(syntax-case #'(slots ...) ()
(((slotnames . _) ...)
(with-syntax ((t (datum->syntax-object #'t (gensym)))
((slotvars ...) (map (lambda (sname)
(if (s1:member sname #'(vars ...) literal-identifier=?)
sname
#''<undefined>))
#'(slotnames ...))))
(with-syntax (((accforms ...)
(let loop ((slots #'(slots ...)) (i 2))
(if (null? slots)
#'()
(with-syntax ((ii i)
((rest ...) (loop (cdr slots) (+ 1 i))))
(syntax-case (car slots) ()
((name get set)
#'((define (get x)
(vector-ref x ii))
(define (set x y)
(vector-set! x ii y))
rest ...))
((name get)
#'((define (get x)
(vector-ref x ii))
rest ...))))))))
#'(begin
(define (conser vars ...) (vector '<record> 't slotvars ...))
(define (pred x) (and (vector? x)
(>= (vector-length x) 2)
(eqv? '<record> (vector-ref x 0))
(eqv? 't (vector-ref x 1))))
accforms ...))))))))
) ; srfi-9
;===========================================================================================
; SRFI-57: RECORDS IMPLEMENTATION IN PORTABLE SYNTAX-CASE:
;
; Andre van Tonder, 2005.
;
;============================================================================================
(module registry (register
make-entry
lookup-entry
lookup-scheme?
lookup-getter
lookup-setter
lookup-labels
lookup-supers
lookup-copier
lookup-predicate)
(import srfi-1)
(import srfi-9)
(define reg '())
(s9:define-record-type entry
(make-entry name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier)
entry?
(name entry.name)
(is-scheme? entry.is-scheme?)
(predicate entry.predicate)
(supers entry.supers)
(labels entry.labels)
(pos-labels entry.pos-labels)
(fields entry.fields)
(copier entry.copier))
(define (register name entry)
(cond ((s1:assoc name reg literal-identifier=?)
=> (lambda (pair)
(set-cdr! pair entry)))
(else
(set! reg (cons (cons name entry)
reg)))))
(define (lookup-entry name)
(s1:assoc name reg literal-identifier=?))
(define (lookup-getter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
literal-identifier=?)
=> cadr)
(else #f)))
(define (lookup-setter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
literal-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
(module portability (syntax->list)
(define (syntax->list x)
(syntax-case x ()
(() '())
((h . t) (cons #'h
(syntax->list #'t)))))
)
(module helpers (parse-declaration
build-record
extend-predicates
extend-copiers
extend-accessors
populate
define-generic
make-generic
define-method
any?)
(import registry)
(import srfi-1)
(import srfi-9)
(import portability)
(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 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 ...))))
literal-identifier=?))
((super ...)
(s1:delete-duplicates (s1:fold-right append
'()
(map lookup-supers
(syntax->list #'(super ...))))
literal-identifier=?)))
(with-syntax
(((pos-label ...)
(if (syntax-object->datum #'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 literal-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-object->datum #'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-object->datum #'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 name 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 name maker (field-label ...) . bindings))))
))))))))) ; build-record
(define (maybe-generate context maybe-identifiers)
(map (lambda (elem)
(if (identifier? elem)
elem
(datum->syntax-object context (gensym))))
maybe-identifiers))
(define (augment-field clause)
(syntax-case clause ()
((label) (maybe-generate #'label `(,#'label getter setter)))
((label getter) (maybe-generate #'label `(,#'label ,#'getter setter)))
((label getter setter) (maybe-generate #'label `(,#'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 name ordering bindings default)
(if (null? (s1:lset-difference literal-identifier=?
(map car bindings)
ordering))
(map (lambda (label)
(cond ((s1:assoc label bindings literal-identifier=?) => (lambda (x) x))
(else `(,label ,default))))
ordering)
(error 'populate "Bindings ~s contains illegal labels. Legal labels for record type ~s are ~s"
(syntax-object->datum bindings)
(syntax-object->datum name)
(syntax-object->datum ordering))))
(syntax-case stx ()
((populate name maker labels . bindings)
(with-syntax ((((label exp) ...) (order #'name
(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 (any? x) #t)
) ; helpers
(module records (define-record-type
define-record-scheme
record-update
record-update!
record-compose
show)
(import srfi-1)
(import registry)
(import portability)
(import helpers)
(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 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 literal-identifier=?
(lookup-labels #'export-name)
(s1:lset-difference literal-identifier=?
(lookup-labels #'import-name)
(syntax->list #'(label ...))))))
(with-syntax (((getter ...)
(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-generic (show x)
(lambda (x) x))
) ; records