wrapper.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          wrapper.lisp
   6 ;;;; Purpose:       Macro wrapper for Hyperobject
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: wrapper.lisp,v 1.3 2002/12/13 07:33:54 kevin Exp $
  11 ;;;;
  12 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package :hyperobject)
  16
  17 (eval-when (:compile-toplevel :execute)
  18   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
  19
  20 #||
  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)))
  24     `(progn
  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))
  31            ,title)
  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))
  41            ,value-func)
  42          (defmethod ho-xml-value-func ((obj ,name))
  43            ,xml-value-func)
  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))
  64          ))))
  65
  66 ||#