Final Version of GOLD (version 4)

GOLD (Version 4)

Conventions

Load Code
Gold (v4)
Graham's OO Code

Some Set-Up
Properties
Speeding Thing Up

Class and Instances
Vectors, not Hashtables

DefProp
Defining Classes
defmeth
Creating Instances

Timm's Extensions
Example
Installation

Download
Execute

Author
Copyright

GOLD (Version 4)

These pages describes more details behing Graham's GOLD system. Those pages (chp 17 of Graham) should be read first.

Conventions

A function named x% or x%% is a preliminary version of a function that will be refined, later.

Anything starting with $ is a UNIX shell command; e.g.

 $ ls
 abcd.lisp       counts.lisp     dist.lisp       macros.lisp     nb.lisp
 bounded.lisp    data.lisp       gold.lisp       make.lisp       random.lisp
 class.lisp      deftest.lisp    knn.lisp        misc.lisp       rbst.lisp

Anything starting with > is a LISP REPL command; e.g.

 > (+ 1 1)
 2

Load Code

  (defun make ()
    (handler-bind ((style-warning #'muffle-warning))
      (format t "% ~a~%" "gold4.lisp")
      (load "gold4.lisp")))

Gold (v4)

GOLD is two sets of functions:

Graham's code with some bug fixes.
Some timm tricks to make working with GOLD, a little easier.

Graham's OO Code

Some Set-Up

To stop a certain debugging error, make sure that we do not do infinite prints of recursive structures.

 (setf *print-array* nil)
 (declaim (inline lookup (setf lookup)))
 (declaim (inline run-methods))

In this program, as in the earlier version, there is no hard distinction between slots and methods. A "method" is just a field with a function in it. But, this nuance will soon be hidden by a more convenient front-end.

Speeding Thing Up

Class and Instances

So far we have not distinguished between classes and instances. We have used a single term, object, to cover both.

While it is elegant and flexible to treat all objects the same, but grossly inefficient. In most object-oriented applications the inheritance graph will be bottom-heavy. In a simulation of traffic, for example, we might have less than ten objects representing classes of vehicles, and hundreds of objects representing particular vehicles. Since the latter will all share a few precedence lists, it is a waste of time to create them, and a waste of space to store them.

So we'll distinguish with classes and instances. Instances are like other objects (which now may as well be called classes), but have only one parent and do not maintain precedence lists.

And since some objects will no longer have precedence lists, the functions rget and get-next are now redefined to look at the parents of such objects instead.

Vectors, not Hashtables

So far we have been representing all objects as hash tables. This gives us more flexibility than we need, at greater cost than we want. Here, we will rewrite our program to represent objects as simple vectors.

Vectors are one-dimensional arrays. We can generate them from lists as follows:

 (coerce all 'simple-vector)

Their slots can be accessed using:

 (svref vector index)

and updated with

 (setf (svref vector index) newThing)

This change will mean giving up the possibility of defining new properties on the fly. So far we can define a property of any object simply by referring to it. Now when a class is created, we will have to give a list of the new properties it has, and when instances are created, they will have exactly the properties they inherit.

Classes and instances are represented as vectors. The first three elements of each will contain information used by the program itself, as modeled bu the following macros:

 (defmacro parents  (v) `(svref ,v 0))
 (defmacro layout   (v) `(the simple-vector (svref ,v 1)))
 (defmacro preclist (v) `(svref ,v 2))

The parents field takes the place of the :parents hash table entry in the old implementation. In a class it will contain a list of parent classes. In an instance it will contain a single parent class.
The layout field will contain a vector of property names, indicating the layout of the class or instance from the fourth element on.
The preclist field takes the place of the :preclist hashtable entry in the old implementation. It will contain the precedence list of a class, or nil in an instance.

Because these operators are macros, they can all be used in the first argument to setf (see below).

DefProp

The macro defprop is essentially unchanged; now it just calls lookup instead of gethash.

If the optional second argument to defprop is true, it expands into a call to run-methods, which is also almost unchanged.

 (defmacro defprop (name &optional meth?)
   `(progn
      ,(if meth?
          `(defun ,name (obj &rest args)
             (run-methods obj ',name args))
          `(defun ,name (obj &rest args)
             (declare (ignore args)) ;tjm: we ignore args for non-methods
             (rget ',name obj nil)))
      (defun (setf ,name) (val obj)
        (setf (lookup ',name obj) val))))

Here's a slightly different run-methods. This one uses the keyword :nil to represent no method. Later on (see the inst method), the default value of all properties will be set to :nil.

 (defun run-methods (obj name args)
   (let ((meth (rget name obj nil)))
     (if (not (eq meth :nil))
         (apply meth obj args)
         (error "No ~A method for ~A." name obj))))

Rget is nearly the same as before. It is so similar to get-next that we can implement both in one function by adding an extra argument. If this extra argument is true, rget takes the place of get-next.

  (defun rget (prop obj next?)
   (let ((prec (preclist obj)))
     (if prec
         (dolist (c (if next? (cdr prec) prec) :nil)
           (let ((val (lookup prop c)))
             (unless (eq val :nil) (return val))))
         (let ((val (lookup prop obj)))
           (if (eq val :nil)
               (rget prop (parents obj) nil)
               val)))))
 
  (defun lookup (prop obj)
   (let ((off (position prop (layout obj) :test #'eq)))
     (if off (svref obj (+ off 3)) :nil)))
 
  (defun (setf lookup) (val prop obj)
   (let ((off (position prop (layout obj) :test #'eq)))
     (if off
         (setf (svref obj (+ off 3)) val)
         (error "Can't set ~A of ~A." val obj))))

Defining Classes

There is a name class with calling something class or slot in COMMON LISP. So we will call them klass or zlot.

The macro class is for creating classes. It takes an optional list of superclasses, followed by zero or more property names (properties are either methods or data slots). It returns an object representing a class.

To define a class (klass), need to run defprop across all the properties.

 (defmacro klass (&optional parents &rest props)
   `(prog1 
        (klass-fn (list ,@parents) ',props)
      ,@(mapcar ; tjm everything is a property
        #'(lambda (x) `(defprop ,x)) props)))

klass-fn runs over all the parents and finds the set of all their properties. This will get converted to a simple vector, for space reasons.

It then creates an object with enough space for all those properties and three more spaces used by the above macros.

  (defun klass-fn (parents props)
    (let* ((all (union (inherit-props parents) props))
          (obj (make-array (+ (length all) 3)
                           :initial-element :nil)))
      (setf (parents obj)  parents
           (layout obj)   (coerce all 'simple-vector)
           (preclist obj) (precedence obj))
      obj))
 
  ; similar to make-precedence, but uses the 
  ; "layout" of the classes
  (defun inherit-props (klasses)
    (delete-duplicates
     (mapcan #'(lambda (c)
                (nconc (coerce (layout c) 'list)
                       (inherit-props (parents c))))
            klasses)))
  
  ; not you again
  (defun precedence (obj)
   (labels ((traverse (x)
              (cons x
                    (mapcan #'traverse (parents x)))))
     (delete-duplicates (traverse obj))))

defmeth

Finally, the function defmeth provides a convenient way to define meth- ods. There are three things new about this version: it does an implicit defprop, it calls lookup instead of gethash, and it calls rget instead of get-next to get the next method.

 
 (defmacro defmeth (name obj parms &rest body)
   (let ((gobj (gensym))
        (inst (gensym)))
     `(let ((,gobj ,obj))
        (defprop ,name t)
        (setf (lookup ',name ,gobj)
              (labels ((next (,inst) ;tjm simple way to call "next"
                        (funcall (rget ',name ,gobj  t) ,inst)))
                #'(lambda ,parms ,@body))))))

Creating Instances

This nearly the same as what we saw before- but note that the default value of all properties is :nil.

 (defun inst0 (parent)
   (let ((obj (copy-seq parent)))
     (setf (parents obj)  parent 
           (preclist obj) nil)
     (fill obj :nil :start 3)
     obj))

Timm's Extensions

I've made the default inst call the lower-level inst0, the send the init method to each.

  (defun inst (parent)
    (let ((obj (inst0 parent)))
      (init  obj) 
      obj))

This only works isf all objects respond to init. So in my extension to GOLD, everything inherits from a master *object* that contains some useful general utilities.

  (defparameter *object* (klass nil ; no parents
                               init with-zlots zlots with-vars))  
  (defmeth init *object* (u)
          "default initialization method: do nothing"
          (declare (ignore u)) 
          t)
  (defmeth zlots *object* (self)
          "return all the properties"
          (coerce (layout (parents self)) 'list))
  (defmeth with-zlots *object* (self fn)
          "iterate over all slots"
         (dolist (zlot (zlots self))
           (funcall fn zlot (lookup zlot self))))
  (defmeth with-vars *object* (self fn)
          "iterate over all slots that are 'dollars'"
         (with-zlots self
             #'(lambda (prop value)
                 (if (dollarp prop)
                     (funcall fn prop value)))))

Note that my code names non-method properties with a $dollar sign. This is optional.

  (defun dollarp (x)
   "does some property name start with $dollar?"
    (and (symbolp x) (equal (elt (symbol-name x) 0) #\$)))

Example

  (defparameter *body* (klass (*object*) area $height volume))
  (defparameter *tube* (klass (*body*) $radius))
 
  (defmeth init *body* (u)    (setf ($height u) 1))
  (defmeth area *tube* (u)    (* pi (expt ($radius u) 2)))
  (defmeth volume *body* (u)  (* ($height u) (area u)))
 
  (defmeth init *tube* (u)
          (next u)
          (setf ($radius u) 10))
  
  (defun !tube ()
    (let ((tub (inst *tube*)))
      (format t "~a~%" (volume tub))
      (with-zlots tub 
        #'(lambda (prop value) 
           (if (dollarp prop)
               (format t "~a = ~a~%" prop value))))
      (with-vars tub
        #'(lambda (prop value)
           (format t "~a = ~a~%" prop value)))))

Installation

Download

Source code:

 $ wget http://unbox.org/wisp/var/timm/11/310/lisp/lib/gold4.lisp

This doco:

 $ wget http://unbox.org/wisp/var/timm/11/310/lisp/gold4.html

Execute

First load into LISP:

 > (load "gold.lisp") ; ignore warning messages

Reloads:

 > (make)

Author

Tim Menzies (tim@menzies.us)

Copyright

Share and enjoy.

This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with this program. If not, see http://www.gnu.org/licenses/.

Prog. Languages