;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: mop.lisp,v 1.4 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: mop.lisp,v 1.5 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
- (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
;; Main class
((cl hyperobject-class) #+(or allegro lispworks) name dsds)
#+allergo (declare (ignore name))
(let* ((dsd (car dsds))
- (ho-type (slot-value dsd 'type)))
+ (ho-type (slot-value dsd 'type))
+ (sql-type (ho-type-to-sql-type ho-type)))
(setf (slot-value dsd 'ho-type) ho-type)
+ (setf (slot-value dsd 'sql-type) sql-type)
(setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
- (setf (slot-value dsd 'sql-type) (ho-type-to-sql-type ho-type))
(let ((ia (compute-effective-slot-definition-initargs
cl #+lispworks name dsds)))
(apply
:print-formatter (slot-value dsd 'print-formatter)
:subobject (slot-value dsd 'subobject)
:hyperlink (slot-value dsd 'hyperlink)
+ :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
:description (slot-value dsd 'description)
- ia)))
- )
+ ia))))
(defun ho-type-to-lisp-type (ho-type)
(check-type ho-type symbol)
(:string
'string)
(:fixnum
- 'fixnum)
+ 'integer)
(:boolean
'boolean)
(:integer
ho-type)))
-
-(defun ho-type-to-sql-type (sqltype)
- (ecase sqltype
- (:string
- 'string)
- (:fixnum
- 'fixnum)
- (:bigint
- 'integer)
- (:short-float
- 'short-float)
- (:long
- 'long-float)
- (:text
- 'string)))
-
;;;; Class initialization function
-(defun process-subobjects (cl)
+(defun finalize-subobjects (cl)
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
subobjects)))
subobjects)))
-(defun process-documentation (cl)
+(defun finalize-documentation (cl)
"Calculate class documentation slot"
(awhen (slot-value cl 'title)
(setf (slot-value cl 'title) (car it)))
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
- (process-subobjects cl)
- (process-views cl)
- (process-sql cl)
- (process-documentation cl))
+ (finalize-subobjects cl)
+ (finalize-views cl)
+ (finalize-hyperlinks cl)
+ (finalize-sql cl)
+ (finalize-documentation cl))
;;;; *************************************************************************