13. Classes, Objects, and Ties

;;;-----------------------------
;; In CL you don't "bless" hash tables (or other data structures), as
;; classes, you just create instances which manage their own storage.
;; See section 13.1 for an example of how to create a more Perl-like
;; object, if you want to.
(setf obj (make-instance 'data::encoder))
;;;-----------------------------
(let ((obj #(3 5)))
  (format t "~A ~A~%" (type-of obj) (aref obj 1))
  (setf obj (make-instance 'human::cannibal))
  ;; This part isn't exactly like the Perl, there's no way to reuse
  ;; the array as the underlying storage for the class (as far as I
  ;; know).
  (format t "~A~%" (type-of obj)))
;; (SIMPLE-VECTOR 2) 5
;; CANNIBAL
;;;-----------------------------
(setf (slot-value obj 'stomach) "Empty" ; directly accessing an object's contents
      (slot-value obj 'NAME) "Thag") ; uppercase field name to make it stand out (optional)
;;;-----------------------------
;; The following won't run (due to data::encoder being fake), it just
;; illustrates the syntax of calling a method.
(setf encoded (encode obj "data"))
;;;-----------------------------
;; Not really different from the above, but more in the spirit of the
;; Perl example.
(setf encoded (data::encode obj "data"))
;;;-----------------------------
;; This is already built in to CL, MAKE-INSTANCE, no need to define it
;; ourselves.
;;;-----------------------------
(setf object (make-instance 'my-class))
;;;-----------------------------
;; No difference from above
;; $object = Class::new("Class");
;;;-----------------------------
;; Note: haven't checked whether the following is the best way to do
;; the following.  It does seem to work tho.

;; The following will only get called if the type is a class.
(defmethod class-only-method ((class standard-class))
  ;; more code here
  )
;; Or you could just write a function
(defun class-only-method (class)
  (check-type class standard-class)
  ;; more code here
  )

;; For more specific classes
(defmethod my-class-only-method ((class (eql (find-class 'my-class))))
  ;; more code here
  )
;; Or you could just write a function
(defun my-class-only-method (class)
  (check-type class #.(find-class 'my-class))
  ;; more code here
  )
;;;-----------------------------
(defparameter *lector* (make-instance 'human::cannibal))
(feed *lector* "Zak")
(move *lector* "New York")
;;;-----------------------------
;; No difference from previous subsection.
;;;-----------------------------
(format *error-output* "stuff here~%")
;;;-----------------------------
;; Not sure what the Perl was trying to show here
(move (slot-value obj 'field))
(move (aref ary i))
;;;-----------------------------
(slot-value (move obj) 'field)
(aref (move ary) i)           ; won't work if ARY is actually an array
;;;-----------------------------
;; Not sure what the Perl code was trying to show
;;;-----------------------------

;;;-----------------------------
;; This entire subsection is specific to Perl's object system (or lack
;; thereof), so it's difficult to write analogous CL code for it.
;; Most of the examples would be done in CL using MAKE-INSTANCE (or a
;; custom function wrapping MAKE-INSTANCE).

;; For the example of an initialization routine, here is one standard
;; way to do it.
(defmethod initialize-instance :after ((obj my-class) &rest init-args)
  "Initialize an object of MY-CLASS"
  (setf (slot-value obj 'SOMETHING) 'mumble
        (slot-value obj 'SOMETHING-ELSE) 'bumble)
  ;; ... etc
  )

;; On the other hand, it wouldn't be sporting not to at least try to
;; mimic the Perl examples, so here goes.  

;; The following will be used in subsequent examples that attempt to
;; be like Perl.
(defclass perl-object () 
  ((_hash :initform (make-hash-table)
          :type hash-table))
  (:documentation "Can be used as a mixin class to make your class
  more Perl-like, or can be used directly."))

(defmethod slot-missing (class (instance perl-object) slot-name operation 
                         &optional (new-value nil new-value-supplied-p))
  (symbol-macrolet ((hash-place (gethash slot-name (slot-value instance '_hash))))
    (if new-value-supplied-p
        (setf hash-place new-value)
        hash-place)))

;; Here's an example of how to use PERL-OBJECT as a "mixin" class to
;; make your class Perl-like (i.e., able to store arbitrary slots in
;; an underlying hash).
(defclass my-perlish-class (perl-object)
  (a b c))

;; Simliar to the new() function in the Perl.
(defun perl-new (class)
  (assert (subtypep class 'perl-object))
  (make-instance class))
;;;-----------------------------
;; No difference
;;;-----------------------------
;; No difference
;;;-----------------------------
(defun new ()
  (let ((self (make-instance 'perl-object))) ; allocate perl-object w/ anonymous hash
    ;; init two sample attributes/data members/fields
    (setf (slot-value self 'START) (get-universal-time)
          (slot-value self 'AGE) 0)
    self))
;;;-----------------------------
(defun new (classname)
  (assert (subtypep classname 'perl-object)) ; Make sure it is of the right type
  (let ((self (make-instance classname))) ; Allocate new memory
    ;; init data fields
    (setf (slot-value self 'START) (get-universal-time)
          (slot-value self 'AGE) 0)
    self))                              ; And give it back
;;;-----------------------------
(defun new (classname &rest initargs)
  (assert (subtypep classname 'perl-object)) ; Make sure it is of the right type
  (let ((self (make-instance classname))) ; Allocate new memory
    ;; init data fields
    (apply '_init self initargs)
    self))                              ; And give it back

;; "private" method to initialize fields.  It always sets START to the
;; current time, and AGE to 0.  If called with arguments, _init
;; interprets them as key+value pairs to initialize the object with.
;; Note that you have to define this for each individual class you
;; want to have it called upon.  In the example below I used
;; MY-PERLISH-CLASS, you'd obviously have to change that to whatever
;; your class was called.
(defmethod _init ((self my-perlish-class) &rest args)
  (setf (slot-value self 'start) (get-universal-time)
        (slot-value self 'age) 0)
  (loop
     for key in args by #'cddr 
     for value in (cdr args) by #'cddr
     do
       (setf (slot-value self key) value)))
;;;-----------------------------

;;;-----------------------------

;; CL has no equivalent to Perl's DESTROY.  Classes that need similar
;; functionality should provide a WITH- macro to handle automatically
;; freeing up the resources in exceptional circumstances.  Here's a
;; skeleton implementation of a macro that one might provide with
;; one's class.
(defmacro with-my-class ((my-obj &rest initargs) &body body)
  `(let ((,my-obj (make-instance 'my-class ,@initargs)))
     (unwind-protect
          (progn ,@body)
       (close ,my-obj)))) ; CLOSE is just an example, should be
                          ; whatever is necessary

;; Even if a condition is signaled, the cleanup code will be called, as in:
;;
;; (with-my-class (obj foo bar) 
;;    (/ 3 0))

;; If you're willing to use a non-standard extension, you can use,
;; e.g., SBCL's SB-EXT:FINALIZE
;;; @@INCOMPLETE@@
;;;-----------------------------

;;;-----------------------------
;; Don't do the following, it's just here to match the Perl snippet.
(defun get-name (self)
  (slot-value self 'name))

(defun set-name (self value)
  (setf (slot-value self 'name) value))
;;;-----------------------------
;; The following is the recommended way to do what the Perl example is
;; doing and is normally preferred to the previous example.  It
;; creates a method called NAME which does, essentially, the same
;; thing as the name() function in the example.
(defclass my-class ()
  ((name :accessor name)))
(setf (name my-obj) 'foo                ; just an example
      val (name my-obj))                ; just an example

;; Just for the record, you could also do this (don't actually do it,
;; this is just to illustrate :READER and :WRITER).
(defclass my-class ()
  ((name :reader get-name :writer set-name)))
(set-name 'foo my-obj)                      ; just an example
(get-name my-obj)                           ; just an example

;; You could also do the same thing as the previous example manually.
(defclass my-class ()
  (name))

(defmethod get-name ((my-obj my-class))
  (slot-value my-obj 'name))

(defmethod set-name ((my-obj my-class) value)
  (setf (slot-value my-obj 'name) value))
;;;-----------------------------
(defun age (obj &optional (value nil value-supplied-p))
  (prog1 (slot-value obj 'age)
    (when value-supplied-p
      (setf (slot-value obj 'age) value))))
;; sample call of get and set: happy birthday!
(age obj (1+ (age obj)))
;;;-----------------------------
(defclass person () 
  ((name :accessor name)
   (age :accessor age)
   (peers :accessor peers)))
(defparameter *him* (make-instance 'person))
(setf (slot-value *him* 'name) "Sylvester"
      (slot-value *him* 'age) 23)
;;;-----------------------------
;; Naming this different from Perl snippet, to avoid clashing with
;; NAME accessor above.
(defun person-name (self &optional (value nil value-supplied-p))
  (if value-supplied-p
      (progn
        ;; CL doesn't have an equivalent of -w (which turns on $^W,
        ;; AFAICT), so we always warn.
        (and (scan "[^\\s\\w'-]" value) (warn "funny characters in name"))
        (and (scan "\\d" value) (warn "numbers in name"))
        (or (scan "\\S+(\\s+\\S+)+" value) (warn "prefer multiword name"))
        (or (scan "\\S" value) (warn "name is blank"))
        (setf (name self) (string-upcase value)))
      (name self)))
;;;-----------------------------
;; Most of this subsection (NAME, AGE, PEERS) is already implemented
;; by the DEFCLASS above.
(defmethod exclaim ((self person))
  (with-accessors ((name name) (age age) (peers peers)) self
    (format nil
            "Hi, I'm ~A, age ~D, working with ~{~A~^, ~}"
            name age peers)))

(defmethod happy-birthday ((self person))
  (incf (age self)))
;;;-----------------------------

;;;-----------------------------
(defclass person ()
  ((gender :accessor gender :initarg :gender)))

(let ((body-count 0))
  (defun population ()
    body-count)
  
  (defmethod initialize-instance :after ((self person) &rest initargs)
    (declare (ignore initargs))
    (incf body-count))
  
  ;; Note that using standard CL you would have to arrange for this to
  ;; be called somehow.  It won't be called automatically by the
  ;; garbage collector, as it would in Perl.
  (defmethod destroy ((self person))
    (declare (ignore self))
    (decf body-count))
  )

(defvar *people* nil)
(loop repeat 10 do (push (make-instance 'person) *people*))
(format t "There are ~D people alive.~%" (population))
;; There are 10 people alive.
;;;-----------------------------
(defparameter *him* (make-instance 'person :gender :male))
(defparameter *her* (make-instance 'person :gender :female))
;;;-----------------------------
(fixed-array-max-bounds 100)            ; set for whole class
(defparameter *alpha* (make-instance 'fixed-array))
(format t "Bound on *alpha* is ~D~%" (max-bounds *alpha*))
;; Bound on *alpha* is 100

(defparameter *beta* (make-instance 'fixed-array))
(max-bounds *beta* 50)                  ; still sets for whole class
(format t "Bound on *alpha* is ~D~%" (max-bounds *alpha*))
;; Bound on *alpha* is 50
;;;-----------------------------
(defclass fixed-array () ())

(let ((bounds 7))
  (macrolet ((bounds-body ()
               `(if value-supplied-p
                    (setf bounds value)
                    bounds)))

    (defmethod max-bounds ((fixed-array fixed-array) &optional (value nil value-supplied-p))
      (bounds-body))

    ;; Don't need this, except to be a little more like the Perl code
    (defun fixed-array-max-bounds (&optional (value nil value-supplied-p))
      (bounds-body))
    ))
;;;-----------------------------
;; Already implemented in previous snippet
;;;-----------------------------
;; Don't do this.  To match the Perl code we have to redefine the
;; above so that FIXED-ARRAY takes a reference to BOUNDS.  The easiest
;; way to do that is to make BOUNDS a symbol, there's no direct way to
;; store a reference to a number in CL since a number can be passed
;; around by value.
(defclass fixed-array () (max-bounds-ref))

(let ((bounds-sym (gensym "BOUNDS-"))) ; a symbol, so we can store a ref to int
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (setf (symbol-value bounds-sym) 7))
  (defmethod initialize-instance :after ((self fixed-array) &rest initargs)
    (declare (ignore initargs))
    (setf (slot-value self 'max-bounds-ref) bounds-sym))

  (defmethod max-bounds ((fixed-array fixed-array) &optional (value nil value-supplied-p))
    (if value-supplied-p
        (setf (symbol-value (slot-value fixed-array 'max-bounds-ref)) value)
        (symbol-value (slot-value fixed-array 'max-bounds-ref))))

  (defun fixed-array-max-bounds (&optional (value nil value-supplied-p))
    (if value-supplied-p
        (setf (symbol-value bounds-sym) value)
        (symbol-value bounds-sym))))
;;;-----------------------------

;;;-----------------------------
;; The closest thing to this example would be CL's built-in
;; structures, which are simpler than CLOS objects and which by
;; default store their slots in vectors.

(defstruct person
  name                                  
  age
  (peers nil :type list))

(defparameter *p* (make-person))     ; allocate an empty Person struct

(setf (person-name *p*) "Jason Smythe") ; set its name field
(setf (person-age *p*) 13)              ; set its age field
(setf (person-peers *p*) '("Wilbur" "Ralph" "Fred")) ; set its peers field

;; fetch various values, including the zeroth friend
(format t "At age ~D, ~A's first friend is ~A.~%"
        (person-age *p*)
        (person-name *p*)
        (car (person-peers *p*)))
;;;-----------------------------
(defstruct person name age)
(defstruct family
  (head (make-person) :type person)
  address
  (members nil :type list))

(defparameter *folks* (make-family))
(defparameter *dad* (family-head *folks*))
(setf (person-name *dad*) "John")
(setf (person-age *dad*) 34)

(format t "~A's age is ~D~%"
        (person-name (family-head *folks*)) 
        (person-age (family-head *folks*)))
;;;-----------------------------
;; You can use DEFMETHOD on any type, not just CLOS objects.
(defmethod age ((person person) &optional (value nil value-supplied-p))
  (if value-supplied-p
      (progn
        (setf (person-age person)
              (if (stringp value)
                  (progn
                    (when (not (scan "^\\d+" value)) 
                      (warn "age `~A' isn't numeric" value))
                    (let ((age (parse-integer value :junk-allowed t)))
                      (when (> age 150)
                        (warn "age `~D' is unreasonable" age))
                      age))
                  value)))
      (person-age person)))
;;;-----------------------------
;; No equivalent to $^W
;;;-----------------------------
;; There's still no equivalent to $^W, but the following illustrates
;; how you could do the rest of what the Perl does.
(let ((gripe (if *should-warn* #'warn #'error)))
  (when (not (scan "^\\d+" value)) 
    (funcall gripe "age `~A' isn't numeric" value))
  (let ((age (parse-integer value :junk-allowed t)))
                      (when (> age 150)
                        (funcall gripe "age `~D' is unreasonable" age))
                      age))
;;;-----------------------------
;; Just use DEFSTRUCT as you did above.
;;;-----------------------------
(defstruct card name color cost type release text)
;;;-----------------------------
;; Don't do this.  Very little point, just defining this macro so that
;; the Perl example can be matched.
(defmacro defstruct* (name slots)
  `(defstruct ,name ,@slots))

(defstruct* card #.(mapcar #'identity '(name color cost type release text)))
;;;-----------------------------
(defstruct* hostent #.(mapcar #'identity '(name 
                                           (aliases nil :type list)
                                           addrtype
                                           length
                                           (addr-list nil :type list))))
;;;-----------------------------
;; What is this supposed to mean?
;;#define h_type h_addrtype
;;#define h_addr h_addr_list[0]
;;;-----------------------------
;; make (hostent-addr hostent-object) same as (hostent-addr-list hostent-object)

;; The following has to be a macro so that all the SETF-related stuff
;; will work correctly.
(defmacro hostent-addr (hostent-object)
  `(hostent-addr-list ,hostent-object))
;;;-----------------------------
;; Not sure what the corresponding Perl snippet was trying to show.
;;;-----------------------------

;;;-----------------------------
;; Skipping this snippet due to Perl-specificity
;;;-----------------------------
(setf ob1 (make-instance 'some-class))
;; later on
(setf ob2 (make-instance (class-of ob1)))
;;;-----------------------------
;; It's a little unclear what the original Perl is doing.  E.g., I
;; have no idea what PARENT is supposed to be.
(defun new-from-proto (proto)
  ;; We don't need to do all the fancy stuff the Perl code does to get
  ;; the superclass' initializers (equivalent of 'new') to run,
  ;; they'll be run automatically by MAKE-INSTANCE.
  (let ((self (make-instance (class-of proto))))
    ;; The following two lines presume that the class being
    ;; instantiated either has START and AGE accessors defined, or
    ;; else inherits the PERL-OBJECT mixin defined earlier in this
    ;; chapter, so that any accessor will work.
    (setf (slot-value self 'start) (get-universal-time) ; init data fields
          (slot-value self 'age) 0)
    self))
;;;-----------------------------
    

;;;-----------------------------
(let ((methname 'flicker)
  (funcall methname obj 10))            ; calls (flicker obj 10) 
    
;; call three methods on the object, by name
(loop for m in '(start run stop)
     do (funcall m obj))
;;;-----------------------------
;; There is no need to do this in CL, in fact in general it won't work
;; because CLOS supports multi-methods, so the method does not
;; "belong" to any one object or class.
;;;-----------------------------
(defparameter *fn-ref* #'(lambda (&rest args) (apply 'my-method args)))
;;;-----------------------------
(funcall *fn-ref* obj 10 "fred")
;;;-----------------------------
(my-method obj 10 "fred")
;;;-----------------------------
;; There is no equivalent of the Perl snippet because methods don't
;; "belong" to a single class.  The following is about as close as you
;; can get but it only works if there is a specific method defined for
;; that class and you know which argument(s) are specialized.
(when (typep (type-of obj) obj-target)
  ;; Find a 3-arg method with the first one specialized to the type of
  ;; OBJ.
  (when (find-method #'my-method '() (list (type-of obj) t t))
    (apply #'my-method obj-target arguments)))
;;;-----------------------------

;;;-----------------------------
(typep obj 'http:message)
;; There is no equivalent to Per's can() method, as described earlier
;; methods don't belong to a single class.  You could use FIND-METHOD
;; as the final example in section 13.7 above shows, althouth that's
;; not recommended.
;;;-----------------------------
(setf has-io (typep fd 'io:handle))
(setf itza-handle (typep fd 'io:handle))
;;;-----------------------------
;; No equivalent.  You could use the following after verifying that
;; OBJ was of the right type.
(setf his-print-method #'as-string)
;;;-----------------------------
;; There's no standardized support for versions in CL.
;;;-----------------------------

;;;-----------------------------
(defclass person ()
  ((name :accessor name :initarg :name)
   (age :accessor age :initarg :age)))
;;;-----------------------------
(let ((dude (make-instance 'person :name "Jason" :age 23)))
  (format t "~A is age ~D.~%" (name dude) (age dude)))
;;;-----------------------------
(defclass employee (person)
  ())
;;;-----------------------------
(let ((empl (make-instance 'employee :name "Jason" :age 23)))
  (format t "~A is age ~D.~%" (name empl) (age empl)))
;;;-----------------------------
;; No equivalent to this "wrong" Perl snippet.
;;;-----------------------------

;;;-----------------------------
(defmethod meth ((self my-class))
  ;; Normally this will result in calling the "superclass" as you
  ;; might think of it in, say, Java.  Note though that CLOS supports
  ;; multiple inheritance, aspect-oriented programming, and various
  ;; other extensions, so CALL-NEXT-METHOD won't *always* do that.
  (call-next-method))
;;;-----------------------------
(meth self)                        ; call wherever first METH is found

;; I can't find any obvious way to do the other examples, you can find
;; a method with FIND-METHOD but there isn't an obviuos way to call it
;; directly on an object.
;;;-----------------------------
;; Don't need to define new(), use MAKE-INSTANCE.

;; Don't need to define _init(), just add an INITIALIZE-INSTANCE
;; method, which will be called automatically and which won't prevent
;; other stuff from running.
(defmethod initialize-instance :after ((self my-class) &rest initargs)
  (with-slots (start age extra)
      (setf (start self) (get-decoded-time) ; init data fields
            (age self)   0
            (extra self) initargs       ; anything extra
;;;-----------------------------
(defparameter *obj* (make-instance 'widget :haircolor :red :freckles 121))
;;;-----------------------------
;; The perl snippet is doing something that's done automatically by
;; CLOS (i.e., all inherited INITIALIZE-INSTANCE methods will be
;; called automatically).
;;;-----------------------------

;;;-----------------------------

;; The equivalent of AUTOLOAD is CLOS's SLOT-MISSING functionality,
;; used to define PERL-OBJECT, above.  In order to add the ok_field
;; behavior, we'll subclass it here.
(defclass person (perl-object) 
  ((ok-field :initform (mkhash 'name t 'age t 'peers t 'parent t)
             :type hash-table
             :allocation :class)))

;; This isn't *exactly* like the Perl snippet, e.g., it doesn't do the
;; uppercase checking or checking for DESTROY.  However, since CL
;; isn't case-sensitive and methods are kept separate from slots,
;; there's no need to do either of those things.
;; 
;; This method "intercepts" SLOT-MISSING, which is normally handled by
;; PERL-OBJECT and lets the call through if the slot name is valid.
(defmethod slot-missing (class (instance person) slot-name operation
                         &optional new-value)
  (declare (ignore new-value operation))
  (if (gethash slot-name (slot-value instance 'ok-field))
      (call-next-method)                ; ok, pass control to PERL-OBJECT
      (error "invalid attribute method ~A" slot-name)))
;;;-----------------------------
(let ((dad (make-instance 'person))
      (kid (make-instance 'person)))
  (setf (slot-value dad 'name) "Jason"
        (slot-value dad 'age) 23
        (slot-value kid 'name) "Rachel"
        (slot-value kid 'age) 2
        (slot-value kid 'parent) dad
        )
  (format t "Kid's parent is ~A~%" (slot-value (slot-value kid 'parent) 'name)))
;; Kid's parent is Jason
;;;-----------------------------
;; The above SLOT-MISSING definition already works the same way as
;; this Perl snippet.
;;;-----------------------------

;;;-----------------------------
;; With respect to this particular Perl snippet, there's no need to
;; define Employee::age as its equivalent is automatically defined by
;; the DEFCLASS below.
;;;-----------------------------
(defpackage :person (:use cl))
(in-package person)
(defclass person ()
  ((name :accessor name)
   (age :accessor age)
   (peers :accessor peers)
   (parent :accessor parent)))

(export '(person name age peers parent))
;;;-----------------------------
(defpackage :employee (:use cl))
(in-package employee)
(defclass employee (person:person)
  ((salary :accessor salary)
   (age :accessor age)
   (boss :accessor boss)))

(export '(employee salary age boss))
;;;-----------------------------
;; The "data inheritance problem", as far as I can tell, is
;; automatically solved by CL in a similar manner to what the Perl is
;; doing.  Being automatic, there is no need to define a custom class
;; like Class::Attributes.  By putting the different classes into
;; different packages, CL automatically distinguishes the slots by the
;; package name.
;;
;; E.g., the above definitions allow you to write (employee:age obj) or
;; (person:age obj) and they access distinct slots.
;;
;; If you *do* want the AGE slot to be shared by the superclasses, you
;; should put the DEFCLASS forms in the same package.
;;;-----------------------------

;;;-----------------------------
(setf (next node) node)
;;;-----------------------------
(defclass node ()
  ((next :accessor next :type node)
   (prev :accessor prev :type node)
   (value :accessor value)))

(defclass ring ()
  ((dummy :accessor dummy :type node)
   (ring-count :accessor ring-count :type number :initform 0)))

(defmethod initialize-instance :after ((self ring) &rest init-args)
  (declare (ignore init-args))
  (let ((dummy (make-instance 'node)))
    (setf (next dummy) dummy
          (prev dummy) dummy
          (value dummy) 'dummy)         ; so PRINT-OBJECT works
    (setf (dummy self) dummy)))
;;;-----------------------------
(loop for i below 20
   do (let ((r (make-instance 'ring)))
        (loop repeat 1000
           do (insert r i))))
;;;-----------------------------
;; Note unlike Perl this isn't called automatically by CL when the
;; object is collected, however some CL implementations provide an
;; extension that could be used to "register" this function as such.
;; Also, depending on the sophistication of your implementation's
;; garbage collector, it might not be necessary to even have this
;; method (since the object doesn't hang on to any external
;; resources).
(defmethod destroy ((ring ring))
  (loop for node = (next (dummy ring)) then (next node)
       until (eq node (dummy ring))
       do (delete-node ring node))
  (setf (prev (dummy ring)) nil
        (next (dummy ring)) nil))
       
(defmethod delete-node ((ring ring) (node node))
  (setf (next (prev node)) (next node)
        (prev (next node)) (prev node))
  (decf (ring-count ring)))
;;;-----------------------------
(defmethod ring-search ((ring ring) value &key (test 'eql))
  "Find VALUE in the RING structure, returning a NODE."
  (loop 
     for node = (next (dummy ring)) then (next node)
     until (eq node (dummy ring))
     do (when (funcall test (value node) value)
          (return-from ring-search node)))
  (dummy ring))

(defmethod insert ((ring ring) value)
  "Insert VALUE into the RING structure."
  (let ((node (make-instance 'node)))
    (setf (value node) value
          (next node) (next (dummy ring))
          (prev (next (dummy ring))) node
          (next (dummy ring)) node
          (prev node) (dummy ring))
    (incf (ring-count ring))))

(defmethod delete-value ((ring ring) value &key (test 'eql))
  "Delete a node from the RING structure by VALUE."
  (let ((node (ring-search ring value :test test)))
    (unless (eq node (dummy ring))
      (delete-node ring node))))

;; just for debugging
(defmethod print-object ((node node) stream)
  (format stream "#<NODE ~A>" (value node)))

(defmethod print-object ((ring ring) stream)
  (format stream "#<RING")
  (do ((node (next (dummy ring)) (next node)))
      ((eq node (dummy ring)))
    (format stream " ~A" node))
  (format stream ">"))
;;;-----------------------------

;;;-----------------------------
;; In CL there is no distinction between operators and functions.
;; However, functions can be "overloaded" by using DEFMETHOD.

(defmethod <=> ((s1 hash-table) (s2 hash-table))
  (let ((s1 (gethash 'name s1))
        (s2 (gethash 'name s2)))
    (case (string-lessp s1 s2)
      (nil (if (string= s1 s2)
               0
               1))
      (t -1))))

;; TODO: write a reader macro for "-like stuff.
;;;-----------------------------
;; The following allows us to implement MY-PLUS without having to
;; prefix most of the function calls, etc, with CL:, which gets
;; old fast.
(defpackage :time-number-internal (:use cl))

;; The following package is where we define the method.  It doesn't
;; use the CL package, so that + can be redefined (redefining anything
;; in the CL package is disallowed by the standard).
(defpackage :time-number)

(in-package time-number)

(cl:defclass time-number ()
  ((seconds :accessor seconds :initform 0 :initarg :seconds)
   (minutes :accessor minutes :initform 0 :initarg :minutes)
   (hours :accessor hours :initform 0 :initarg :hours)
   ))

(cl:defmethod + ((left time-number) (right time-number))
  (time-number-internal::my-plus left right))

(cl:export 'time-number)

;; There's no need to do anything like "use overload", you can just
;; use DEFMETHOD directly, as shown below.
;;;-----------------------------
(in-package time-number-internal)

;; The following can safely assume that LEFT and RIGHT are TIME-NUMBER
;; objects, since this is only called by the TIME-NUMBER:+ method
;; specialized on TIME-NUMBER.
(defun my-plus (left right)
  (let ((answer (make-instance 'time-number:time-number)))
    (with-accessors ((answer-seconds seconds) (answer-minutes minutes) (answer-hours hours)) answer
      (setf answer-seconds (+ (seconds left)
                              (seconds right))
            answer-minutes (+ (minutes left)
                              (minutes right))
            answer-hours (+ (hours left)
                            (hours right)))
      (when (>= answer-seconds 60)
        (setf answer-seconds (mod answer-seconds 60))
        (incf answer-minutes))
      (when (>= answer-minutes 60)
        (setf answer-minutes (mod answer-minutes 60))
        (incf answer-hours)))
    answer))
;;;-----------------------------
;;; @@INCOMPLETE@@
;;;-----------------------------