[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>
                      (lambda (x)       ; unique proc per new type
                        (and (eq? me? x)
                             (begin (set! *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?*
                           (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)
                             (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?)
               (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"

;Value: #f

(set! *U-domain-extended?* #T)

;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
;;             ^^^^^^^^^^^
;;[should read SELECTOR, right?]
;;      <object>))
;;               ^
;;               +
;;    = <object>

;Value: universal-selector

;Error: D/U mismatch ((u-tag) . #[compound-procedure 35])

;Value: #f

(set! *universal-selector?* #T)

;Value: #t

;Value: <object>