[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: New types; also opacity without passkeys [portable R4RS impl]
Date: Thu, 23 May 96 17:16:49 -0400
From: Guillermo J. Rozas <gjr@martigny.ai.mit.edu>
Cc: ziggy@martigny.ai.mit.edu, rrrs-authors@martigny.ai.mit.edu
Reply-To: gjr@martigny.ai.mit.edu
| Date: Thu, 23 May 96 00:17 EDT
| Cc: rrrs-authors@martigny.ai.mit.edu
| Reply-To: jaffer@ai.mit.edu
| From: Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
|
| I also tried to write such a program using only procedure opacity and
| convinced myself that there was no way to redefine PAIR? or PROCEDURE?
| so that new-types were disjoint from R4RS types while preserving
| opacity.
I would like to understand this part. If you allow redefinition of
existing procedures so that code distinct from this package uses the
new definition, you should be able to implement this, albeit
painfully.
This would not be a practical solution, but I'm not sure that this
proposal is based on practicality anyway.
I started to type up my (dis)proof, when I discovered that, although
making records part of PAIR? or PROCEDURE? space is ugly, it works
nicely to carve out a niche from VECTORs. This is a practical enough
solution that I will be using this code in SLIB.
Date: Wed, 15 May 1996 22:00:11 +0000
From: William D Clinger <will@ccs.neu.edu>
...
Although this proposal does not explicitly require any opacity,
the requirement that the predicate P? returns #T if and only if
its argument was created by a call to U cannot be implemented
without some kind of opacity. In particular, this proposal
cannot be implemented in R4RS Scheme.
My criteria for whether this can "be implemented in R4RS Scheme" is
less stringent than Ziggy's. As long as procedures are opaque and the
following code is loaded before other programs, it will give disjoint
record types which are unforgable and uncorruptable by R4RS
procedures. Vectors (not records) are still READable and WRITEable
without redefining those procedures
If the magic-cookie is made a circular list, records become opaque in
a more traditional meaning of the word -- since trying to print a
record will result in "(((((((((((((((((((((((((((((..."
With the knowledge that opaque data *can* be constructed from opaque
R4RS procedures, what now changes?
-=-=-=-=-
; "record.scm" record data types
; Written by David Carlton, carlton@husc.harvard.edu.
; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu
;
; This code is in the public domain.
; Implements `record' data structures for Scheme. Using only the
; opacity of procedures, makes record datatypes and
; record-type-descriptors disjoint from R4RS types and each other, and
; prevents forgery and corruption (modification without using
; RECORD-MODIFIER) of records.
(require 'common-list-functions)
(define vector? vector?)
(define vector-ref vector-ref)
(define vector-set! vector-set!)
(define vector-fill! vector-fill!)
(define vector->list vector->list)
(define record-modifier #f)
(define record-accessor #f)
(define record-constructor #f)
(define record-predicate #f)
(define make-record-type #f)
(let (;; Need to close these to keep magic-cookie hidden.
(make-vector make-vector)
(vector vector)
;; We have to wrap these to keep magic-cookie hidden.
(vect? vector?)
(vect-ref vector-ref)
(vect->list vector->list)
;; Need to wrap these to protect record data from being corrupted.
(vect-set! vector-set!)
(vect-fill! vector-fill!)
(nvt "of non-vector type")
)
(letrec
(;; Tag to identify rtd's. (A record is identified by the rtd
;; that begins it.)
(magic-cookie (cons 'rtd '()))
(rtd? (lambda (object)
(and (vect? object)
(not (= (vector-length object) 0))
(eq? (rtd-tag object) magic-cookie))))
(rec? (lambda (obj)
(and (vect? obj)
(>= (vector-length obj) 1)
(or (eq? magic-cookie (rec-rtd obj))
(rtd? (rec-rtd obj))))))
(vec:error
(lambda (proc-name msg obj)
(slib:error proc-name msg
(cond ((rtd? obj) 'rtd)
((rec? obj) (rtd-name (rec-rtd obj)))
(else obj)))))
;; Internal accessor functions. No error checking.
(rtd-tag (lambda (x) (vect-ref x 0)))
(rtd-name (lambda (rtd) (vect-ref rtd 1)))
(rtd-fields (lambda (rtd) (vect-ref rtd 3)))
;; rtd-vfields is padded out to the length of the vector, which is 1
;; more than the number of fields
(rtd-vfields (lambda (rtd) (cons #f (rtd-fields rtd))))
;; rtd-length is the length of the vector.
(rtd-length (lambda (rtd) (vect-ref rtd 4)))
(rec-rtd (lambda (x) (vect-ref x 0)))
(make-rec-type
(lambda (type-name field-names)
(if (not (string? type-name))
(slib:error 'make-record-type "non-string type-name argument."
type-name))
(if (or (and (list? field-names) (comlist:has-duplicates? field-names))
(comlist:notevery symbol? field-names))
(slib:error 'make-record-type "illegal field-names argument."
field-names))
(let* ((augmented-length (+ 1 (length field-names)))
(rtd (vector magic-cookie
type-name
'()
field-names
augmented-length
#f
#f)))
(vect-set! rtd 5
(lambda (x)
(and (vect? x)
(= (vector-length x) augmented-length)
(eq? (rec-rtd x) rtd))))
(vect-set! rtd 6
(lambda (x)
(and (vect? x)
(>= (vector-length x) augmented-length)
(eq? (rec-rtd x) rtd)
#t)))
rtd)))
(rec-predicate
(lambda (rtd)
(if (not (rtd? rtd))
(slib:error 'record-predicate "invalid argument." rtd))
(vect-ref rtd 5)))
(rec-constructor
(lambda (rtd . field-names)
(if (not (rtd? rtd))
(slib:error 'record-constructor "illegal rtd argument." rtd))
(if (or (null? field-names)
(equal? field-names (rtd-fields rtd)))
(let ((rec-length (- (rtd-length rtd) 1)))
(lambda elts
(if (= (length elts) rec-length) #t
(slib:error 'record-constructor
(rtd-name rtd)
"wrong number of arguments."))
(apply vector rtd elts)))
(let ((rec-vfields (rtd-vfields rtd))
(corrected-rec-length (rtd-length rtd))
(field-names (car field-names)))
(if (or (and (list? field-names) (comlist:has-duplicates? field-names))
(comlist:notevery (lambda (x) (memq x rec-vfields))
field-names))
(slib:error
'record-constructor "invalid field-names argument."
(cdr rec-vfields)))
(let ((field-length (length field-names))
(offsets
(map (lambda (field) (comlist:position field rec-vfields))
field-names)))
(lambda elts
(if (= (length elts) field-length) #t
(slib:error 'record-constructor
(rtd-name rtd)
"wrong number of arguments."))
(let ((result (make-vector corrected-rec-length)))
(vect-set! result 0 rtd)
(for-each (lambda (offset elt)
(vect-set! result offset elt))
offsets
elts)
result)))))))
(rec-accessor
(lambda (rtd field-name)
(if (not (rtd? rtd))
(slib:error 'record-accessor "invalid rtd argument." rtd))
(let ((index (comlist:position field-name (rtd-vfields rtd)))
(augmented-length (rtd-length rtd)))
(if (not index)
(slib:error 'record-accessor "invalid field-name argument."
field-name))
(lambda (x)
(if (and (vect? x)
(>= (vector-length x) augmented-length)
(eq? rtd (rec-rtd x)))
#t
(slib:error 'record-accessor "wrong record type." x "not" rtd))
(vect-ref x index)))))
(rec-modifier
(lambda (rtd field-name)
(if (not (rtd? rtd))
(slib:error 'record-modifier "invalid rtd argument." rtd))
(let ((index (comlist:position field-name (rtd-vfields rtd)))
(augmented-length (rtd-length rtd)))
(if (not index)
(slib:error 'record-modifier "invalid field-name argument."
field-name))
(lambda (x y)
(if (and (vect? x)
(>= (vector-length x) augmented-length)
(eq? rtd (rec-rtd x)))
#t
(slib:error 'record-modifier "wrong record type." x "not" rtd))
(vect-set! x index y)))))
)
(set! vector? (lambda (obj) (and (not (rec? obj)) (vector? obj))))
(set! vector-ref
(lambda (vector k)
(cond ((rec? vector)
(vec:error 'vector-ref nvt vector))
(else (vect-ref vector k)))))
(set! vector->list
(lambda (vector k)
(cond ((rec? vector)
(vec:error 'vector->list nvt vector))
(else (vect->list vector k)))))
(set! vector-set!
(lambda (vector k obj)
(cond ((rec? vector)
(vec:error 'vector-set! nvt vector))
(else (vect-set! vector k obj)))))
(set! vector-fill!
(lambda (vector fill)
(cond ((rec? vector)
(vec:error 'vector-fill! nvt vector))
(else (vect-fill! vector fill)))))
(set! record-modifier rec-modifier)
(set! record-accessor rec-accessor)
(set! record-constructor rec-constructor)
(set! record-predicate rec-predicate)
(set! make-record-type make-rec-type)
))