[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
New types; also opacity without passkeys [portable R4RS impl]
Will Clinger writes in his proposal:
>---------------------------------------------------------------------------
> 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.
>---------------------------------------------------------------------------
Yes, it can. Following is a portable R4RS implementation that I have
tested in both MIT Scheme and Scheme 48. It relies _only_ on the
opacity of LAMBDA closures.
;---------------------------------------------------------------------------
(define *universal-selector?* #f) ; Later toggled to #T
(define *U-domain-extended?* #f) ; ditto
(define make-new-type
(let* ((*UID-counter* 0) ; Global counter so each <type> unique
;; Some kernel level data abstractions for U'd data
(*U-tag* (list 'U-tag))
(%U-tag (lambda (x) (cons *U-tag* x)))
(%U-tagged? (lambda (x) (and (pair? x) (eq? (car x) *U-tag*))))
(%U-untag (lambda (U-tagged-obj) (cdr U-tagged-obj))))
(lambda ()
(set! *UID-counter*
(+ 1 *UID-counter*)) ; Each new <type> gets a unique ID
(letrec ((me? (let ((*state* ; Unique state datum per <type>
*UID-counter*))
(lambda (x) ; unique proc per new type
(and (eq? me? x)
(begin (set! *state* (- *state*))
*state*))))))
(let ((U (lambda (<datum>)
(%U-tag ; (U <object>) yields a tagged...
(lambda (downer) ; ...proc of one arg (for opaque me?)
(cons (me? downer) ; If that one arg is me?
<datum>))))) ; then unveil the <datum> (WIN tagged)
(D (lambda (object)
(if (not (%U-tagged? object))
(if *U-domain-extended?*
object
(error "Error: Cannot D an un-U'd object" object))
(let ((WIN-flag
((%U-untag object) me?))) ; Check U <type> match
;; If D/U match [i.e., WIN-flag = (WIN . <datum>)]
;; (or if unconditionally unveil)
;; then return the unveiled <datum>
(if (or (car WIN-flag)
*universal-selector?*)
(cdr WIN-flag)
(error "Error: D/U mismatch" object))))))
(P? (lambda (object)
(let ((WIN-flag
(and (%U-tagged? object)
((%U-untag object) me?)))) ; Check U <type>
;; If U match, then WIN-flag = (WIN . <datum>)
;; but be sure to return boolean T/F.
(and WIN-flag
(not (not (car WIN-flag)))))))
)
;;
;; A <type> is an opaque procedure to package its
;; constructor/selector/predicate & me?
;;
(lambda (message)
(case message
((U) U)
((D) D)
((P?) P?)
(else
(error "Error: Unrecognized message" message)))))))))
(define (get-new-constructor <type>) (<type> 'U))
(define (get-new-selector <type>) (<type> 'D))
(define (get-new-predicate <type>) (<type> 'P?))
;---------------------------------------------------------------------------
Here is a transcript of me testing this in MIT Scheme (the same results
obtained for Scheme 48).
;---------------------------------------------------------------------------
;; MAKE-NEW-TYPE takes no arguments. The result of MAKE-NEW-TYPE
;; is not a predicate, but a new type descriptor <type> that is
;; different from all existing type descriptors.
(define <type> (MAKE-NEW-TYPE))
(eq? <type> (MAKE-NEW-TYPE))
;Value: #f
;; (GET-NEW-CONSTRUCTOR <type>),
;; (GET-NEW-SELECTOR <type>), and
;; (GET-NEW-PREDICATE <type>)
;;
;; respectively return a constructor U, a selector D, and a predicate P?
;; that satisfy the following constraints.
(define U (GET-NEW-CONSTRUCTOR <type>))
(define D (GET-NEW-SELECTOR <type>))
(define P? (GET-NEW-PREDICATE <type>))
;; Let <type2> be the result of a call
;; to MAKE-NEW-TYPE that is dynamically distinct from the call
;; that returned <type>.
(define <type2> (MAKE-NEW-TYPE))
;; Let <object> be any object, and let <object2> be any object that
;; was not constructed by U.
(define <object> ((get-new-constructor <type2>) "<object>'"))
(define <object2> "Any object that was not constructed by U")
;; Then
;;1. (GET-NEW-CONSTRUCTOR <type>) = U that is, successive
;;2. (GET-NEW-SELECTOR <type>) = D calls return the
;;3. (GET-NEW-PREDICATE <type>) = P? same procedures
(eq? (GET-NEW-CONSTRUCTOR <type>) U)
;Value: #t
(eq? (GET-NEW-SELECTOR <type>) D)
;Value: #t
(eq? (GET-NEW-PREDICATE <type>) P?)
;Value: #t
;;4. (P? (U <object>)) = #T
(P? (U <object>))
;Value: #t
;;5. (P? <object2>) = #F
(P? <object2>)
;Value: #f
;;6. ((GET-NEW-PREDICATE <type2>) <object>) = #F [as per your proposal]
((GET-NEW-PREDICATE <type2>) <object>)
;Value: #t
;;6. ((GET-NEW-PREDICATE <type2>) (U <object>)) = #F [as per my correction]
;; ^^ ^
;; ++ +
((GET-NEW-PREDICATE <type2>) (U <object>))
;Value: #f
;;7. (D (U <object>)) = <object> where the equality is to be
;; interpreted as EQV?
(EQV? (D (U <object>)) <object>)
;Value: #t
;;;...in fact...
(eq? (D (U <object>)) <object>)
;Value: #t
;;8. (D <object2>) is an error so implementations are free
;; to extend the domain of D
;; to include all objects
(D <object2>)
;Error: Cannot D an un-U'd object "Any object that was not constructed by U"
*U-domain-extended?*
;Value: #f
(set! *U-domain-extended?* #T)
*U-domain-extended?*
;Value: #t
(D <object2>)
;Value 34: "Any object that was not constructed by U"
;;For example, this proposal allows, but by no means requires, an
;;implementation to provide a UNIVERSAL-SELECTOR such that
;;
;; (GET-NEW-CONSTRUCTOR (MAKE-NEW-TYPE)) = UNIVERSAL-SELECTOR
;; ^^^^^^^^^^^
;;[should read SELECTOR, right?]
;;
;;and
;; (UNIVERSAL-SELECTOR
;; ((GET-NEW-CONSTRUCTOR (MAKE-NEW-TYPE))
;; <object>))
;; ^
;; +
;; = <object>
(define UNIVERSAL-SELECTOR (GET-NEW-SELECTOR (MAKE-NEW-TYPE)))
;Value: universal-selector
(UNIVERSAL-SELECTOR
((GET-NEW-CONSTRUCTOR (MAKE-NEW-TYPE))
'<object>))
;Error: D/U mismatch ((u-tag) . #[compound-procedure 35])
*universal-selector?*
;Value: #f
(set! *universal-selector?* #T)
*universal-selector?*
;Value: #t
(UNIVERSAL-SELECTOR
((GET-NEW-CONSTRUCTOR (MAKE-NEW-TYPE))
'<object>))
;Value: <object>
;---------------------------------------------------------------------------'