-;;; Builder macros.
-
-(export 'define-sod-class)
-(defmacro define-sod-class (name (&rest superclasses) &body body)
- "Construct a new SOD class called NAME in the current module.
-
- The new class has the named direct SUPERCLASSES, which should be a list of
- strings.
-
- The BODY begins with a sequence of alternating keyword/value pairs
- defining properties for the new class. The keywords are (obviously) not
- evaluated, but the value forms are.
-
- The remainder of the BODY are a sequence of forms to be evaluated as an
- implicit `progn'. Additional macros are available to the BODY, to make
- defining the class easier.
-
- In the following, NAME is a string giving a C identifier; NICK is a string
- giving the nickname of a superclass; TYPE is a C type using S-expression
- notation.
-
- * message NAME TYPE &rest PLIST
-
- * method NICK NAME TYPE BODY &rest PLIST
-
- * slot NAME TYPE &rest PLIST
-
- * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
-
- * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
-
- (let ((plist nil)
- (classvar (gensym "CLASS-")))
- (loop
- (when (or (null body)
- (not (keywordp (car body))))
- (return))
- (push (pop body) plist)
- (push (pop body) plist))
- `(let ((,classvar (make-sod-class ,name
- (mapcar #'find-sod-class
- (list ,@superclasses))
- (make-property-set
- ,@(nreverse plist)))))
- (macrolet ((message (name type &rest plist)
- `(make-sod-message ,',classvar ,name (c-type ,type)
- (make-property-set ,@plist)))
- (method (nick name type body &rest plist)
- `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
- ,body (make-property-set ,@plist)))
- (slot (name type &rest plist)
- `(make-sod-slot ,',classvar ,name (c-type ,type)
- (make-property-set ,@plist)))
- (instance-initializer
- (nick name value-kind value-form &rest plist)
- `(make-sod-instance-initializer ,',classvar ,nick ,name
- ,value-kind ,value-form
- (make-property-set
- ,@plist)))
- (class-initializer
- (nick name value-kind value-form &rest plist)
- `(make-sod-class-initializer ,',classvar ,nick ,name
- ,value-kind ,value-form
- (make-property-set
- ,@plist))))
- ,@body
- (finalize-sod-class ,classvar)
- (add-to-module *module* ,classvar)))))