chickadee » coops

coops

Introduction

COOPS is an object system for Scheme that provides

Usage

(import coops)

and optionally

(import coops-primitive-objects)

Requirements

matchable record-variants

Reference

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
(define-class CLASSNAME [(SUPERCLASS ...) [(SLOTSPEC ...) CLASSOPTION ...]])syntax

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
(make-class [CLASSNAME] (SUPERCLASS ...) [(SLOTNAME ...) [METACLASS]])syntax

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
class-name CLASSprocedure

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

subclass?
subclass? CLASS1 CLASS2procedure

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

Instance creation

make
make CLASS SLOTNAME1 INITFORM1 ...procedure

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
class-of Xprocedure

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

initialize-instance
initialize-instance OBJECTprocedure

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?
generic-procedure? Xprocedure

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

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

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
(define-method (NAME [QUALIFIER] [(ARGUMENT1 CLASS1) ...] ...) BODY ...)syntax

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
(make-generic-procedure ARGUMENT ...)syntax

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
slot-value OBJECT SLOTNAMEprocedure

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-exists?
slot-exists? OBJECT SLOTNAMEprocedure

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

slot-initialized?
slot-initialized? OBJECT SLOTNAMEprocedure

Returns #t if the slot named SLOTNAME in OBJECT has been initialized. If the slot does not exist, an error is signalled.

Predefined classes

<standard-object>
<standard-object>class

The base class of classes defined with define-class.

<standard-class>
<standard-class>class

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

<generic-procedure>
<generic-procedure>class

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

#t

The superclass of all other classes.

Predefined generic procedures

print-object
print-object OBJECT PORTprocedure

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
(define-primitive-class NAME [(SUPERCLASS ...)] PREDICATE)syntax

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.

<primitive-object>class

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>:

ClassObject typeSuperclasses
<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

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

Repository

This egg is hosted on the CHICKEN Subversion repository:

https://anonymous@code.call-cc.org/svn/chicken-eggs/release/5/coops

If you want to check out the source code repository of this egg and you are not familiar with Subversion, see this page.

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.3


Added slot-exists?.
1.2


Disabled interrupts during execution of COOPS runtime procedures.
1.1


Use proper record-type tag-variable instead of unqualified record type name, fix missing source-dependency.
1.0


Initial release for CHICKEN 5, based on version 1.7 from CHICKEN 4






Contents »