1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: wrapper.lisp
6 ;;;; Purpose: Macro wrapper for Hyperobject
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package :hyperobject)
17 (eval-when (:compile-toplevel :execute)
18 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
21 (defmacro define-hyperobject (name parents fields &rest meta-fields)
22 (let* ((meta-fields (process-meta-fields fields meta-fields))
23 (cl-fields (process-hyper-fields fields meta-fields)))
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (defclass ,name ,(append parents (list 'hyperobject)) ,cl-fields
27 ,@meta-fields))(and documentation (list (list :documentation documentation)))))
28 (let ((,value-func (compile nil (eval (slot-value ,meta 'value-func))))
29 (,xml-value-func (compile nil (eval (slot-value ,meta 'xml-value-func)))))
30 (defmethod ho-title ((obj ,name))
32 (defmethod ho-name ((obj ,name))
33 ,(string-downcase (symbol-name name)))
34 (defmethod ho-fields ((obj ,name))
35 ',(slot-value meta 'fields))
36 (defmethod ho-references ((obj ,name))
37 ',(slot-value meta 'references))
38 (defmethod ho-subobjects ((obj ,name))
39 ',(slot-value meta 'subobjects))
40 (defmethod ho-value-func ((obj ,name))
42 (defmethod ho-xml-value-func ((obj ,name))
44 (defmethod ho-fmtstr-text ((obj ,name))
45 ,(slot-value meta 'fmtstr-text))
46 (defmethod ho-fmtstr-html ((obj ,name))
47 ,(slot-value meta 'fmtstr-html))
48 (defmethod ho-fmtstr-xml ((obj ,name))
49 ,(slot-value meta 'fmtstr-xml))
50 (defmethod ho-fmtstr-text-labels ((obj ,name))
51 ,(slot-value meta 'fmtstr-text-labels))
52 (defmethod ho-fmtstr-html-labels ((obj ,name))
53 ,(slot-value meta 'fmtstr-html-labels))
54 (defmethod ho-fmtstr-xml-labels ((obj ,name))
55 ,(slot-value meta 'fmtstr-xml-labels))
56 (defmethod ho-fmtstr-html-ref ((obj ,name))
57 ,(slot-value meta 'fmtstr-html-ref))
58 (defmethod ho-fmtstr-xml-ref ((obj ,name))
59 ,(slot-value meta 'fmtstr-xml-ref))
60 (defmethod ho-fmtstr-html-ref-labels ((obj ,name))
61 ,(slot-value meta 'fmtstr-html-ref-labels))
62 (defmethod ho-fmtstr-xml-ref-labels ((obj ,name))
63 ,(slot-value meta 'fmtstr-xml-ref-labels))