Re: Scheme mico (was Re: Python mico)

[mike olan com (Michael N. Livshin)]

Jan Kautz <jnkautz@cip.informatik.uni-erlangen.de> writes:

>  Server in Scheme:
> 
>  (load-from-ir "account")
>  ; here we need some kind of object system for Scheme (yasos?), that
>  ; must be able to do separate declaration and definition of object methods:

I'm just starting on CORBA, so can't comment on the really interesting
issues here, but there's an object system for Guile that I wrote a while
back whose purpose is exactly to tack predefined interfaces on top of
existing objects conveniently.

I'm appending the code, as it is not big.
Feel free to ask me any questions.

---------------->8------- cut --------8<--------------
;;; pint.scm --- A Pure INTerface-based OOP system
;; -*- Scheme -*-
; Copyright (C) 1998 Michael Livshin

;; Commentary:

;I. Introduction

; There are 4 concepts that are used here:

; 1. Interface type.
;    Has methods (just names), can have ancestors (multiple too).

; 2. Interface mapping.
;    A concrete implementation of an interface for some data type.

; 3. Interface.
;    Interface mapping + data the mapping operates on.

; 4. Method.
;    A generic method (dispatching on the first argument).

; Let's look at an example:

; Definition 1:
; an *iterator* is a thing that points to data in some
; container. With an iterator, you can look at a piece of data,
; change it to something else, and you also can move an iterator
; to the next piece of data.
; So, we define an Iterator interface type as having three methods
; (iterator-ref, iterator-set!, iterator-move-next!) and no ancestors.

; (define Iterator (make-interface-type "iterator"       ; the name of the interface type
;                                       ()               ; ancestor list (empty)
;                                       (iterator-ref    ; methods
;                                        iterator-set!
;                                        iterator-move-next!)))

; We also define the appropriate generic methods:

; (define iterator-ref (make-generic-method 'iterator-ref))
; (define iterator-set! (make-generic-method 'iterator-set!))
; (define iterator-move-next! (make-generic-method 'iterator-move-next!))

; Definition 2:
; a *bidirectional iterator* is a kind of *iterator* that can also
; move to the previous piece of data.
; So, we define a BidirectionalIterator as inheriting from Iterator
; and having one additional method - iterator-move-previous.

; (define BidirectionalIterator (make-interface-type "bidirectional iterator"
;                                                    ;; inherit from Iterator:
;                                                    (Iterator)
;                                                    (iterator-move-previous!)))

; (define iterator-move-previous! (make-generic-method 'iterator-move-previous!))

; Next, we define a mapping from lists to iterators:

; (define list-mapping (make-interface-mapping "list->iterator mapping"
;                                              ;; The interface we implement:
;                                              Iterator
;                                              ;; The methods:
;                                              #:iterator-ref
;                                              (lambda (iterator)
;                                                (car
;                                                 (interface-data iterator)))
;                                              #:iterator-set!
;                                              (lambda (iterator value)
;                                                (error "list iterators are read-only"))
;                                              #:iterator-move-next!
;                                              (lambda (iterator)
;                                                (set-interface-data!
;                                                 iterator
;                                                 (cdr (interface-data iterator))))))
; ;; A function to construct an iterator for a list:
; (define (list->iterator l)
;   (make-interface
;    list-mapping     ; The mapping to use
;    l                ; The data to operate on
;    ))

; Having done the above, we can do something like this:

; (define li (list->iterator '(a b c d e)))

; (iterator-ref li)         ; will return 'a
; (iterator-move-next! li)
; (iterator-set! li 'foo)   ; will signal an error
; (iterator-ref li)         ; will return 'b

;II. Reference.

; 1. Importing this module.
;    (use-modules (oo pint))

; 2. Public functions and macros.
; 2.1. Interface type - related.

;  (make-interface-type name ancestors methods [defaulters])
;    name
;       - a name that will be used when write'ing the type object
;    ancestors
;       - type ancestor list (unquoted)
;    methods
;       - type method list (unquoted)
;    defaulters (optional)
;       - a sequence of keywords and values or a single association list.
;
;         Defaulters are useful to provide default implementations for
;         methods in an interface type.
;         Each keyword is a name of a method in this type, and
;         value is a function meeting these requirements:
;         a) takes one argument, the list of all type methods that
;            are defined so far.
;         b) returns either a function that meets the requirements for
;            method implementation, or #f
;         The defaulters are used when defining interface mappings, to
;         add missing method implementations.

;  (make-interface-type* name ancestors methods [defaulters])
;    This is like make-interface-type, but it is a proper function (not
;    syntax), so ancestors and methods must be quoted.

;  (interface-type-name type)
;    Returns the type's name

;  (interface-type-methods type)
;    Lists the type's methods. Note: all methods will be listed, including
;    those required by parent types.

;  (interface-type-ancestors type)
;    Lists the type's ancestors. Note: all ancestors will be listed, including
;    the immediate ancestors' ancestors.

;  (interface-type-predicate type)
;    Returns a function that can be used to test interface types.

; 2.2. Generic method - related.

;  (make-generic-method name)
;    Makes a generic method that will dispatch to the method named `name'
;    as implemented by the interface mapping of the first argument.

; 2.3. Interface mapping - related.

;  (make-interface-mapping name type [method-impls])
;    name
;       - a name that will be used when write'ing the mapping object
;    type
;       - the interface type being implemented
;    method-impls
;       - a sequence of keyword and values or a single association list.
;         Keyword is a name of a method being implemented.
;         Value is a function that takes one or more arguments,
;         where the first argument is an interface (see concept 3 above).

;  (interface-mapping-name imapping)
;    Returns the mapping's name

;  (interface-mapping-type imapping)
;    Returns the interface type that the mapping implements

;  (interface-mapping-explicit-methods imapping)
;    Returns all the type's methods that are explicitly implemented
;    by this mapping.

;  (interface-mapping-method imapping method-name)
;    Returns the mapping's implementation for the named method.

; 2.4. Interface - related.

;  (make-interface imapping data)
;    Construct a new interface, having the implementation `imapping' and data `data'.

;  (interface-mapping iface)
;    Returns iface's mapping.

;  (interface-type iface)
;    Returns iface's type.

;  (interface-data iface)
;    Returns iface's data.

;  (set-interface-data! iface value)
;    Sets iface's data to value.

;; Code

(define-module (oo pint))

(use-modules (ice-9 common-list))

(define *interface-type-rtd*
  (make-record-type "interface type"
                    '(name methods predicate ancestors
                           method-num defaulters)
                    (lambda (obj port)
                      (display "#<type " port)
                      (write (interface-type-name obj) port)
                      (display ">" port))))
(define primitive-make-interface-type
  (record-constructor *interface-type-rtd*))
(define-public interface-type-name
  (record-accessor *interface-type-rtd* 'name))
(define-public interface-type-methods
  (record-accessor *interface-type-rtd* 'methods))
(define-public interface-type-ancestors
  (record-accessor *interface-type-rtd* 'ancestors))
(define interface-type-method-num
  (record-accessor *interface-type-rtd* 'method-num))
(define interface-type-defaulters
  (record-accessor *interface-type-rtd* 'defaulters))
(define-public interface-type-predicate
  (record-accessor *interface-type-rtd* 'predicate))
(define set-interface-type-predicate!
  (record-modifier *interface-type-rtd* 'predicate))

(define (uniq-alist alist)
  (if (null? alist)
      '()
      (let ((u (uniq-alist (cdr alist))))
        (if (assq (caar alist) u)
            u
            (cons (car alist) u)))))

(define-public (kw-list->alist arg)
  (cond
   ((= 1 (length arg))
    (car arg))
   (#t
    (let loop ((args arg) (res '()))
      (if (null? args)
          res
          (loop (cddr args)
                (cons (cons (keyword->symbol (car args))
                            (cadr args))
                      res)))))))

(define (get-mapping-method mapping method)
  (let ((method-impl
         (hashq-ref (interface-mapping-method-hash mapping)
                    method)))
    (or method-impl
        (error "no method" method "defined for type"
               (interface-type-name (interface-mapping-type mapping))))))

(define (get-method iface method)
  (get-mapping-method (interface-mapping iface) method))

(define-public (make-generic-method method)
  (lambda args
    (apply (get-method (car args) method)
           args)))

(define-public (make-generic-constructor method)
  (lambda args
    (apply (get-mapping-method (car args) method)
           args)))

(define (is-a itype key)
  (or (eq? itype key)
      (not (not (memq key (interface-type-ancestors itype))))))

(define-public (make-interface-type* name ancestors methods . defaulters)
  (let* ((uniq-ancestors (uniq ancestors))
         (all-ancestors (reduce-init union
                                     uniq-ancestors
                                     (map (lambda (a)
                                            (interface-type-ancestors a))
                                          uniq-ancestors)))
         (inherited-methods (uniq (apply append
                                         (map interface-type-methods
                                              uniq-ancestors))))
         (inherited-defaulters (uniq-alist (apply append
                                                  (map interface-type-defaulters
                                                       uniq-ancestors))))
         (new-defaulters (kw-list->alist defaulters))
         (all-defaulters (append! new-defaulters
                                  (remove-if (lambda (df)
                                               (assq (car df) new-defaulters))
                                             inherited-defaulters)))
         (new-methods (remove-if (lambda (method)
                                   (memq method inherited-methods))
                                 (uniq methods)))
         (all-methods (append! new-methods
                               inherited-methods)))
    (let ((itype (primitive-make-interface-type name
                                                all-methods
                                                #f
                                                all-ancestors
                                                (length all-methods)
                                                all-defaulters)))
      (set-interface-type-predicate! itype
                                     (lambda (iface)
                                       (is-a (interface-type iface) itype)))
      itype)))

(defmacro-public make-interface-type (name ancestors methods . defaulters)
  `(make-interface-type* ,name
                         (list ,@ancestors)
                         ',methods
                         ,@defaulters))

(define *interface-mapping-rtd*
  (make-record-type "interface mapping"
                    '(name type method-hash explicit-methods data)
                    (lambda (obj port)
                      (display "#<mapping " port)
                      (write (interface-mapping-name obj) port)
                      (display " (type: " port)
                      (write (interface-type-name (interface-mapping-type obj)) port)
                      (display " data: " port)
                      (write (interface-mapping-data obj) port)
                      (display ")>" port))))
(define primitive-make-interface-mapping
  (record-constructor *interface-mapping-rtd*))
(define-public interface-mapping-name
  (record-accessor *interface-mapping-rtd* 'name))
(define-public interface-mapping-type
  (record-accessor *interface-mapping-rtd* 'type))
(define-public interface-mapping-data
  (record-accessor *interface-mapping-rtd* 'data))
(define-public interface-mapping-explicit-methods
  (record-accessor *interface-mapping-rtd* 'explicit-methods))
(define-public set-interface-mapping-data!
  (record-modifier *interface-mapping-rtd* 'data))
(define interface-mapping-method-hash
  (record-accessor *interface-mapping-rtd* 'method-hash))
(define set-interface-mapping-method-hash!
  (record-modifier *interface-mapping-rtd* 'method-hash))

(define-public (interface-mapping-method mapping method)
  (let ((impl (hashq-ref (interface-mapping-method-hash mapping)
                        method)))
    (or impl
        (error "no method" method "defined for type"
               (interface-type-name (interface-mapping-type mapping))))))

(define *interface-rtd*
  (make-record-type "interface"
                    '(mapping data)
                    (lambda (obj port)
                      (display "#<interface (" port)
                      (write (interface-mapping obj) port)
                      (display " data: " port)
                      (write (interface-data obj) port)
                      (display ")>"))))
(define-public make-interface
  (record-constructor *interface-rtd*))
(define-public interface-mapping
  (record-accessor *interface-rtd* 'mapping))
(define-public interface-data
  (record-accessor *interface-rtd* 'data))
(define-public set-interface-data!
  (record-modifier *interface-rtd* 'data))

(define-public (interface-type iface)
  (interface-mapping-type (interface-mapping iface)))

(define (expand-methods defaulters methods)
  (let loop ((methods methods) (size (length methods)))
    (let* ((new-methods
            (let loop ((defaulters defaulters) (res methods))
              (if (null? defaulters)
                  res
                  (loop (cdr defaulters)
                        (if (assq-ref methods (caar defaulters))
                            res
                            (let ((new-method ((cdar defaulters) methods)))
                              (if new-method
                                  (cons (cons (caar defaulters) new-method)
                                        res)
                                  res)))))))
           (new-size (length new-methods)))
      (if (> new-size size)
          (loop new-methods new-size)
          new-methods))))

(define-public (make-interface-mapping name itype . methods)
  (let* ((explicit-methods (kw-list->alist methods))
         (methods (expand-methods (interface-type-defaulters itype)
                                  explicit-methods))
         (method-hash (make-vector (interface-type-method-num itype))))

    ;; Check that all methods are defined:
    (for-each (lambda (method)
                (or
                 (assq method methods)
                 (error "no definition given for method" (car method))))
              (interface-type-methods itype))

    ;; Fill the method hash:
    (for-each (lambda (method)
                (hashq-set! method-hash (car method) (cdr method)))
              methods)

    (primitive-make-interface-mapping name
                                      itype
                                      method-hash
                                      explicit-methods
                                      #f)))

;; Interfaces that are supposed to be more or less standard and useful:

;; Clonable
(define-public clonable (make-interface-type "clonable"
                                             ()
                                             (clone-data)))

(define-public clone-interface-data (make-generic-method 'clone-data))

(define-public clonable? (interface-type-predicate clonable))

(define-public (clone-interface iface)
  (make-interface (interface-mapping iface)
                  (clone-interface-data iface)))

;;; pint.scm ends here
---------------->8------- cut --------8<--------------