255 lines
7.3 KiB
Scheme
255 lines
7.3 KiB
Scheme
|
|
|
|
|
|
(let ()
|
|
|
|
(define rtd?
|
|
(lambda (x)
|
|
(and ($record? x)
|
|
(eq? ($record-rtd x) $base-rtd))))
|
|
|
|
(define rtd-name
|
|
(lambda (rtd)
|
|
($record-ref rtd 0)))
|
|
|
|
(define rtd-length
|
|
(lambda (rtd)
|
|
($record-ref rtd 1)))
|
|
|
|
(define rtd-fields
|
|
(lambda (rtd)
|
|
($record-ref rtd 2)))
|
|
|
|
(define rtd-printer
|
|
(lambda (rtd)
|
|
($record-ref rtd 3)))
|
|
|
|
(define rtd-symbol
|
|
(lambda (rtd)
|
|
($record-ref rtd 4)))
|
|
|
|
(define set-rtd-name!
|
|
(lambda (rtd name)
|
|
($record-set! rtd 0 name)))
|
|
|
|
(define set-rtd-length!
|
|
(lambda (rtd n)
|
|
($record-set! rtd 1 n)))
|
|
|
|
(define set-rtd-fields!
|
|
(lambda (rtd fields)
|
|
($record-set! rtd 2 fields)))
|
|
|
|
(define set-rtd-printer!
|
|
(lambda (rtd printer)
|
|
($record-set! rtd 3 printer)))
|
|
|
|
(define set-rtd-symbol!
|
|
(lambda (rtd symbol)
|
|
($record-set! rtd 4 symbol)))
|
|
|
|
(define make-rtd
|
|
(lambda (name fields printer symbol)
|
|
(let ([rtd ($make-record $base-rtd 5)])
|
|
($record-set! rtd 0 name)
|
|
($record-set! rtd 1 (length fields))
|
|
($record-set! rtd 2 fields)
|
|
($record-set! rtd 3 printer)
|
|
($record-set! rtd 4 symbol)
|
|
rtd)))
|
|
|
|
(define verify-field
|
|
(lambda (x)
|
|
(unless (symbol? x)
|
|
(error 'make-record-type "~s is not a valid field name" x))))
|
|
|
|
(define set-fields
|
|
(lambda (r f* i n)
|
|
(cond
|
|
[(null? f*)
|
|
(if ($fx= i n)
|
|
r
|
|
#f)]
|
|
[($fx< i n)
|
|
(if (null? f*)
|
|
#f
|
|
(begin
|
|
($record-set! r i ($car f*))
|
|
(set-fields r ($cdr f*) ($fxadd1 i) n)))]
|
|
[else #f])))
|
|
|
|
(define make-record-type
|
|
(lambda (name fields)
|
|
(unless (string? name)
|
|
(error 'make-record-type "name must be a string, got ~s" name))
|
|
(unless (list? fields)
|
|
(error 'make-record-type "fields must be a list, got ~s" fields))
|
|
(for-each verify-field fields)
|
|
(make-rtd name fields #f (gensym name))))
|
|
|
|
|
|
(define record-type-name
|
|
(lambda (rtd)
|
|
(unless (rtd? rtd)
|
|
(error 'record-type-name "~s is not an rtd" rtd))
|
|
(rtd-name rtd)))
|
|
|
|
|
|
(define record-type-symbol
|
|
(lambda (rtd)
|
|
(unless (rtd? rtd)
|
|
(error 'record-type-symbol "~s is not an rtd" rtd))
|
|
(rtd-symbol rtd)))
|
|
|
|
(define record-type-field-names
|
|
(lambda (rtd)
|
|
(unless (rtd? rtd)
|
|
(error 'record-type-field-names "~s is not an rtd" rtd))
|
|
(rtd-fields rtd)))
|
|
|
|
|
|
(define record-constructor
|
|
(lambda (rtd)
|
|
(unless (rtd? rtd)
|
|
(error 'record-constructor "~s is not an rtd"))
|
|
(lambda args
|
|
(let ([n (rtd-length rtd)])
|
|
(let ([r ($make-record rtd n)])
|
|
(or (set-fields r args 0 n)
|
|
(error 'record-constructor
|
|
"incorrect number of arguments to the constructor of ~s"
|
|
rtd)))))))
|
|
|
|
(define record-predicate
|
|
(lambda (rtd)
|
|
(unless (rtd? rtd)
|
|
(error 'record-predicate "~s is not an rtd"))
|
|
(lambda (x)
|
|
(and ($record? x)
|
|
(eq? ($record-rtd x) rtd)))))
|
|
|
|
(define field-index
|
|
(lambda (i rtd who)
|
|
(cond
|
|
[(fixnum? i)
|
|
(unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
|
|
(error who "~s is out of range for rtd ~s" rtd))
|
|
i]
|
|
[(symbol? i)
|
|
(letrec ([lookup
|
|
(lambda (n ls)
|
|
(cond
|
|
[(null? ls)
|
|
(error who "~s is not a field in ~s" rtd)]
|
|
[(eq? i ($car ls)) n]
|
|
[else (lookup ($fx+ n 1) ($cdr ls))]))])
|
|
(lookup 0 (rtd-fields rtd)))]
|
|
[else (error who "~s is not a valid index" i)])))
|
|
|
|
(define record-field-accessor
|
|
(lambda (rtd i)
|
|
(unless (rtd? rtd)
|
|
(error 'record-field-accessor "~s is not an rtd" rtd))
|
|
(let ([i (field-index i rtd 'record-field-accessor)])
|
|
(lambda (x)
|
|
(unless (and ($record? x)
|
|
(eq? ($record-rtd x) rtd))
|
|
(error 'record-field-accessor "~s is not of type ~s" x rtd))
|
|
($record-ref x i)))))
|
|
|
|
(define record-field-mutator
|
|
(lambda (rtd i)
|
|
(unless (rtd? rtd)
|
|
(error 'record-field-mutator "~s is not an rtd" rtd))
|
|
(let ([i (field-index i rtd 'record-field-mutator)])
|
|
(lambda (x v)
|
|
(unless (and ($record? x)
|
|
(eq? ($record-rtd x) rtd))
|
|
(error 'record-field-mutator "~s is not of type ~s" x rtd))
|
|
($record-set! x i v)))))
|
|
|
|
(define record?
|
|
(lambda (x . rest)
|
|
(if (null? rest)
|
|
($record? x)
|
|
(let ([rtd ($car rest)])
|
|
(unless (null? ($cdr rest))
|
|
(error 'record? "too many arguments"))
|
|
(unless (rtd? rtd)
|
|
(error 'record? "~s is not an rtd"))
|
|
(and ($record? x)
|
|
(eq? ($record-rtd x) rtd))))))
|
|
|
|
(define record-rtd
|
|
(lambda (x)
|
|
(if ($record? x)
|
|
($record-rtd x)
|
|
(error 'record-rtd "~s is not a record" x))))
|
|
|
|
(define record-length
|
|
(lambda (x)
|
|
(if ($record? x)
|
|
(rtd-length ($record-rtd x))
|
|
(error 'record-length "~s is not a record" x))))
|
|
|
|
(define record-name
|
|
(lambda (x)
|
|
(if ($record? x)
|
|
(rtd-name ($record-rtd x))
|
|
(error 'record-name "~s is not a record" x))))
|
|
|
|
(define record-printer
|
|
(lambda (x)
|
|
(if ($record? x)
|
|
(rtd-printer ($record-rtd x))
|
|
(error 'record-printer "~s is not a record" x))))
|
|
|
|
(define record-ref
|
|
(lambda (x i)
|
|
(unless ($record? x) (error 'record-ref "~s is not a record" x))
|
|
(unless (fixnum? i) (error 'record-ref "~s is not a valid index" i))
|
|
(let ([n (rtd-length ($record-rtd x))])
|
|
(unless (and ($fx>= i 0) ($fx< i n))
|
|
(error 'record-ref "index ~s is out of range for ~s" i x))
|
|
($record-ref x i))))
|
|
|
|
(define record-set!
|
|
(lambda (x i v)
|
|
(unless ($record? x) (error 'record-set! "~s is not a record" x))
|
|
(unless (fixnum? i) (error 'record-set! "~s is not a valid index" i))
|
|
(let ([n (rtd-length ($record-rtd x))])
|
|
(unless (and ($fx>= i 0) ($fx< i n))
|
|
(error 'record-set! "index ~s is out of range for ~s" i x))
|
|
($record-set! x i v))))
|
|
|
|
(primitive-set! 'make-record-type make-record-type)
|
|
(primitive-set! 'record-type-name record-type-name)
|
|
(primitive-set! 'record-type-symbol record-type-symbol)
|
|
(primitive-set! 'record-type-field-names record-type-field-names)
|
|
(primitive-set! 'record-constructor record-constructor)
|
|
(primitive-set! 'record-predicate record-predicate)
|
|
(primitive-set! 'record-field-accessor record-field-accessor)
|
|
(primitive-set! 'record-field-mutator record-field-mutator)
|
|
|
|
(primitive-set! 'record? record?)
|
|
(primitive-set! 'record-rtd record-rtd)
|
|
(primitive-set! 'record-type-descriptor record-rtd)
|
|
(primitive-set! 'record-name record-name)
|
|
(primitive-set! 'record-printer record-printer)
|
|
(primitive-set! 'record-length record-length)
|
|
(primitive-set! 'record-ref record-ref)
|
|
(primitive-set! 'record-set! record-set!)
|
|
|
|
(set-rtd-fields! $base-rtd '(name fields length printer symbol))
|
|
(set-rtd-name! $base-rtd "base-rtd")
|
|
(set-rtd-printer! $base-rtd
|
|
(lambda (x p)
|
|
(unless (rtd? x)
|
|
(error 'record-type-printer "not an rtd"))
|
|
(display "#<" p)
|
|
(display (rtd-name x) p)
|
|
(display " rtd>" p)))
|
|
|
|
)
|
|
|