Outdated egg!

This is an egg for CHICKEN 4, the unsupported old release. You're almost certainly looking for the CHICKEN 5 version of this egg, if it exists.

If it does not exist, there may be equivalent functionality provided by another egg; have a look at the egg index. Otherwise, please consider porting this egg to the current version of CHICKEN.

COOPS provides classes, generic functions and methods, similar in style and use to the classic Lisp object systems like Flavors, Loops or CLOS. For general information about object-oriented programming in the context of Lisp, consult one of the various books and guides available to the subject.

Classes

define-class

[syntax] (define-class CLASSNAME [(SUPERCLASS ...) [(SLOTSPEC ...) CLASSOPTION ...]])

Defines a COOPS class and assigns it to the variable CLASSNAME (which should be a symbol). (SUPERCLASS ...) is a list of expressions evaluating to classes from which the newly defined class should inherit. If no superclasses are given or the superclass list is empty, then <standard-object> is assumed to be the default superclass.

SLOTSPEC specifies a slot (commonly called an instance variable) and should be either a symbol naming the slot or a list of the form (SLOTNAME SLOTOPTION1 OPTIONVALUE1 ...). The syntax (SLOTNAME INITFORM) is also a valid SLOTSPEC and is equivalent to (SLOTNAME initform: INITFORM).

An instance always contains all the slots of all superclasses in addition to its own slots.

Classes are first-class values and are actually instances themselves, of the class <standard-class> (see below for more details).

Slot options

reader:

 [slot option] reader: NAME

Defines a method on the generic procedure NAME that takes an instance of the defined class as its sole argument and returns the value of the instance slot with the same name. This is equivalent to

(define-method (NAME (obj CLASSNAME)) (slot-value obj 'NAME))

writer:

 [slot option] writer: NAME

Defines a method on the generic procedure NAME that takes as arguments an instance of the defined class argument and a value and assigns the value to the instance slot with the same name. This is equivalent to

(define-method (NAME (obj CLASSNAME) val) (set! (slot-value obj 'NAME) val))

accessor:

 [slot option] accessor: NAME

Similar to

(begin
  (define-method (NAME (obj CLASSNAME)) (slot-value obj 'NAME))
  (define-method ((setter NAME) (obj CLASSNAME) val) (set! (slot-value obj 'NAME) val)))

So, we are defining a generic procedure method for accessing the slot, together with a setter that allows assigning new values to the slot with the syntax

(set! (NAME obj) val)

initform:

 [slot option] initform: EXPRESSION

If an instance of the defined class is created and this slot has not been given an initialization argument, then EXPRESSION will be evaluated and the result assigned to the slot.

Class options

metaclass:

 [class option] metaclass: CLASS

The class of which the newly defined class should be an instance (classes are instances, too). The default meta-class is <standard-class>. Use this option if you feel adventurous.

make-class

[syntax] (make-class [CLASSNAME] (SUPERCLASS ...) [(SLOTNAME ...) [METACLASS]])

Defines a class. define-class is syntactic sugar around this form and is usually preferred. make-class allows the creation of anonymous (that is: unnamed) classes.

Note that make-class is syntax, not a procedure.

class-name

[procedure] (class-name CLASS)

Returns the name of CLASS, if it has one, or #f it not.

subclass?

[procedure] (subclass? CLASS1 CLASS2)

Returns #t if CLASS1 is equal to CLASS2 or if it is a subclass of CLASS2 or #f otherwise.

Instance creation

make

[procedure] (make CLASS SLOTNAME1 INITFORM1 ...)

Creates an instance of the CLASS and initializes the slots given in the remaining arguments. The new instance is returned. Slots not given which have been declared to have an initform: will be initialized by evaluating that form. All other slots will be uninitialized.

class-of

[procedure] (class-of X)

Returns the class of X or #t if X is not a class instance.

initialize-instance

[procedure] (initialize-instance OBJECT)

A generic procedure that is automatically invoked after a call to make and which initializes the remaining slots of OBJECT to initforms given in the class definition. If you just want to use this as a constructor, (call-next-method) can be used to initialize the slots.

Generic procedures

Generic procedures are like normal procedures but contain a hidden reference to a generic procedure object that holds additional information like method-tables, etc. You can define generic procedures explicitly with the define-generic and make-generic-procedure syntactic forms or implicitly by using define-method.

slot-value and class-of can be used on generic procedures and will transparently access the generic procedure object

generic-procedure?

[procedure] (generic-procedure? X)

Returns #t if X is a generic procedure or #f otherwise.

define-generic

[syntax] (define-generic (NAME ARGUMENT ...))

Defines a generic procedure, a procedure specialized for one or more argument types. ARGUMENT ... defines the number of specialized arguments this generic procedure shoud use to dispatch to the correct method. The generic procedure may receive additional arguments, but those will not be used to determine the method. This form is roughly equivalent to

(define NAME
  (make-generic-procedure ARGUMENT ...))

You can use the syntax

(define-generic ((setter NAME) ARGUMENT ...))

to define a SRFI-17 setter on NAME that is itself a generic procedure.

define-method

[syntax] (define-method (NAME [QUALIFIER] [(ARGUMENT1 CLASS1) ...] ...) BODY ...)

Defines a method specialized for arguments of the classes CLASS1 ... on the generic procedure NAME. If NAME holds a method for the same argument classes, the previously defined method is replaced.

If no generic procedure has previously been defined for NAME, then a generic procedure definition is done implicitly. Whether it can be assumed a definition exists is assumed to be the case when one of the following holds true:

NAME is an imported value binding
a generic procedure has been defined with (define-generic NAME ...) in the same compilation unit or the same interpreter session and is lexically visible

(define-method ((setter NAME) ...) BODY ...)

is allowed and supported.

QUALIFIER may be one of the keywords primary:, before:, after: or around: and mark the method as being either a primary (default) method, a method that is called before or after the primary method or a method that is "wrapped" around more specific methods. before: methods are invoked from most specific to least specific. after: methods are invoked from least specific to most specific. around: methods can chose to invoke the next most specific method with the same arguments by calling (call-next-method) with no arguments.

All arguments of the form (ARGUMENT CLASS) are specialized up to the first occurrence of a plain symbol or until a "rest"-argument or extended lambda-list marker (#!rest, #!optional or #!key) is encountered.

make-generic-procedure

[syntax] (make-generic-procedure ARGUMENT ...)

Creates a generic procedure, a procedure decorated with a hidden generic procedure object of class <generic-procedure>. ARGUMENT ... is the list of specialized arguments this procedure should receive. Methods for this generic procedure may accept more required or optional arguments, but the number of specialized arguments must be the same.

Note that make-generic-procedure is syntax, not a procedure.

Slot access

slot-value

[procedure] (slot-value OBJECT SLOTNAME)

Returns the slot named SLOTNAME of the class instance OBJECT, signalling an error if no such slot exists.

(set! (slot-value OBJECT SLOTNAME) VAL)

can be used to assign a value to a slot.

slot-initialized?

[procedure] (slot-initialized? OBJECT SLOTNAME)

Returns #t if OBJECT has a slot named SLOTNAME or #f ortherwise.

Predefined classes

<standard-object>

[class] <standard-object>

The base class of classes defined with define-class.

<standard-class>

[class] <standard-class>

The class of classes (classes are class instances themselves). This implies that <standard-class> is an instance of itself.

<generic-procedure>

[class] <generic-procedure>

A subclass of <procedure> that is the class of generic procedure objects.

#t

The superclass of all other classes.

Predefined generic procedures

print-object

[procedure] (print-object OBJECT PORT)

A generic procedure that is invoked when OBJECT is printed.

Primitive classes

Primitive classes are classes representing primitive data objects like numbers, strings and record structures. To be able to define generic procedures specialized on these types, primitive classes can be defined and associated with a predicate that returns a true value for objects that should be considered of the type represented by the class.

define-primitive-class

[syntax] (define-primitive-class NAME [(SUPERCLASS ...)] PREDICATE)

Defines a primitive class with the name NAME and the given list of superclasses. If no superclasses are specified, then the superclass list defaults to (<primitive-object>). PREDICATE should be a procedure of one argument determining whether the argument is a member of the newly defined primitive class.

The predicate should be referentially transparent.

Predefined primitive classes

The extension coops-primitive-objects defines additional classes that allow defining generic procedures on objects used in the CHICKEN core libraries.

[class] <primitive-object>

This is the base class of all primitive object classes. Load the extension coops-primitive-objects to pull in <primitive-object> and its derivatives.

Other classes deriving from <primitive-object>:

Class	Object type	Superclasses
`<immediate>`	Any immediate object	`<primitive-object>`
`<boolean>`	`#t` or `#f`	`<immediate>`
`<eof-object>`	end of file	`<immediate>`
`<char>`	Characters	`<immediate>`
`<record>`	Record instances	`<primitive-object>`
`<sequence>`		`<primitive-object>`
`<list>`		`<sequence>`
`<null>`	The empty list	`<immediate> <list>`
`<pair>`		`<list>`
`<vector>`	Vectors	`<sequence>`
`<number-vector>`	SRFI-4 vectors	`<sequence> <record>`
`<u8vector>`		`<number-vector>`
`<s8vector>`		`<number-vector>`
`<u16vector>`		`<number-vector>`
`<s16vector>`		`<number-vector>`
`<u32vector>`		`<number-vector>`
`<s32vector>`		`<number-vector>`
`<f32vector>`		`<number-vector>`
`<f64vector>`		`<number-vector>`
`<string>`		`<sequence>`
`<char-set>`	SRFI-13 char sets	`<sequence> <record>`
`<symbol>`		`<primitive-object>`
`<keyword>`	Keyword symbols	`<symbol>`
`<number>`		`<primitive-object>`
`<integer>`		`<number>`
`<exact-number>`		`<integer>`
`<inexact-number>`		`<number>`
`<fixnum>`		`<exact-number> <immediate>`
`<flonum>`		`<inexact-number>`
`<thread>`	SRFI-18 thread	`<record>`
`<mutex>`	SRFI-18 mutex	`<record>`
`<condition-variable>`	SRFI-18 condition variables	`<record>`
`<condition>`	Condition objects	`<record>`
`<tcp-listener>`		`<record>`
`<continuation>`		`<record>`
`<regexp>`	Regular expression	`<record>`
`<pointer>`	Machine pointer	`<primitive-object>`
`<locative>`		`<record>`
`<promise>`	created with `delay`	`<record>`
`<queue>`		`<sequence> <record>`
`<hash-table>`		`<sequence> <record>`
`<blob>`		`<primitive-object>`
`<port>`		`<record>`
`<stream-port>`	file port	`<port>`
`<custom-port>`		`<port>`
`<string-port>`		`<port>`
`<tcp-port>`		`<port>`
`<procedure>`		`<primitive-object>`

Bugs and limitations

define-generic, define-method and make-generic-procedure do currently not check for argument-list congruence, so it is important to make sure that the number of specialized arguments is always correct for the given generic procedure.

Examples

A simple class:

(define-class <stack> ()
  ((content '())))              ; or "(content initform: '())"

(define-method (push (val #t) (stack <stack>))
  (set! (slot-value stack 'content) (cons val (slot-value stack 'content))))

(define-method (pop (stack <stack>))
  (let* ((c (slot-value stack 'content))
         (x (car c)))
    (set! (slot-value stack 'content) (cdr c))
    x))

(define-method (empty? (stack <stack>))
  (null? (slot-value stack 'content)))

A subclass of <stack>, with logging:

(define-class <stack-with-logging> (<stack>)
  ((logfile initform: (current-output-port) accessor: stack-logfile)))

(define-method (push before: (val #t) (stack <stack-with-logging>))
  (with-output-to-port (stack-logfile stack)  ; uses accessor method
    (lambda () (print "stack: pushing " val))))

(define-method (pop before: (stack <stack-with-logging>))
  (with-output-to-port (stack-logfile stack)
    (lambda ()
      (print "stack: popping " (car (slot-value stack 'content))))))

(define-method ((setter stack-logfile) before: (stack <stack-with-logging>) file)
  (print "stack: setting logfile to " file))

An example of a custom initialize-instance with call-next-method:

(define-class <c> ()
  ((type initform: 'int reader: type))
  ((content)))

(define-method (initialize-instance (c <c>))
    (call-next-method)
    (set! (slot-value c 'content) (if (eq? (type c) 'int) 0 "")))

Author

COOPS is based on ScmObj by Dorai Sitaram and was ported to CHICKEN and heavily extended by felix winkelmann

License

Copyright (c) 1996, Dorai Sitaram
All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
conditions are met:

  Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    disclaimer. 
  Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    disclaimer in the documentation and/or other materials provided with the distribution. 
  Neither the name of the author nor the names of its contributors may be used to endorse or promote
    products derived from this software without specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

Version History

1.7: fixed missing compile-time load of srfi-1 (thanks to Moritz Heidkamp)
1.6: fixed call to test-exit in test script
1.5: added call to test-exit in test script
1.4: made <list> an abstract type, since the type-predicates for primitive classes were not disjoint (thanks to Sandro)
1.3: syntax needed to import srfi-1 (thanks to Moritz Heidkamp)
1.2: modified to use include to handle changes in module syntax (sjamaan)
1.1: made <pair> and <null> subclasses of <list>
1.0: proper initform-handling for all classes
0.9: metaclass-related bugfixes (thanks to Peter Lane)
0.8: fixed bug related to initforms and inheritance
0.7: added type-check in internal slot-lookup procedure (thanks to Kon Lovett)
0.6: removed declaration which is broken on older CHICKENs (4.5.1)
0.5: added type-check in make (thanks to Peter Lane)
0.4: added <integer> class to coops-primitive-objects
0.3: added license to .meta file
0.2: performance tweaks, fix for 4.5.2 dependency (thanks to Mario)
0.1: initial release