) (02/20/90)
;;; -*- Mode:Common-Lisp; Fonts:(MEDFNT MEDFNTB HL12BI HL12B CPTFONTB); Base:10 -*-
;1;; FEB 19, 1990* 1CRH. original version. debugged on several structures.*
;1;; if you've been faced with converting DEFSTRUCTs to CLOS,*
;1;; this stuff should help.*
;1;; two examples are included at the bottom.*
;1;; at the moment, Feb 20, 1990, it doesn't do BOA-constructors.*
;1;; I haven't used them, so I don't have a satisfactory test case.*
;1;;if you try to use one, it warns you about it.*
;1;; otherwise, I think it does everything else about DEFSTRUCTS.*
;1;; this would work best with either the super-shift-m macro (com-macro-replace)*
;1;; or a modified version of that which worked off another keystroke and*
;1;; applied this macro to the form and then replaced it in the buffer.*
;1;; this currently allows you to goof and apply it to something which is NOT*
;1;; a DEFSTRUCT without harm--it returns the original form.*
(DEFMACRO 4convert-defstruct-to-class* ((defstruct? name&options &body slots)
&aux (temp ()) (doc-str ()))
"2Converts a STRUCT definition into a CLASS definition.*"
(IF (EQUAL defstruct? 'DEFSTRUCT) ;1if it were accidentally applied to something else*
(PROGN
(IF (STRINGP (CAR slots)) ;1DEFSTRUCT has an optional doc-string.*
(SETQ doc-str (CAR slots)
slots (CDR slots)))
(LET ((includes ()) ;1these are the basic options for the whole structure.*
(conc-name ())
(constructor ())
(copier ())
(predicate ())
(print-function ())
(type ())
(named ())
(initial-offset ())
(name ()))
;1;get the values of the structure options.*
(TYPECASE name&options
(ATOM (SETQ name name&options
named t)) ;1it is NAMED, by default.*
(LIST (SETQ name (CAR name&options)
includes (CADR (MEMBER :include name&options))
conc-name (FIRSTN 2 (CADR (MEMBER :conc-name name&options)))
constructor (OR (CAR (MEMBER :constructor name&options ;1if it's a BOA-cons*
:test #'(lambda (item elt)
(WHEN (LISTP elt)
(EQUAL item (CAR elt))))))
(FIRSTN 2 (CADR (MEMBER :constructor name&options)))) ;1ordinary.*
copier (FIRSTN 2 (CADR (MEMBER :copier name&options)))
predicate (FIRSTN 2 (CADR (MEMBER :predicate name&options)))
print-function (FIRSTN 2 (CADR (MEMBER :print-function name&options)))
type (FIRSTN 2 (CADR (MEMBER :type name&options))) ;1not relevant*
named (OR (NOT (CAR type)) (MEMBER :named name&options))
initial-offset (FIRSTN 2 (CADR (MEMBER :initial-offset name&options))) ;1not relevant*
))
)
;1;if no CONSTRUCTOR was spec'd, make a default.*
(IF (NOT (CAR constructor))
(SETQ constructor (READ-FROM-STRING
(CONCATENATE 'STRING "3MAKE-*" (STRING name))))
;1;ELSE, if it was spec'd as NIL, don't do one at all*
(CASE (LENGTH constructor)
(2 (SETQ constructor (CADR constructor)))
(3 (SETQ constructor (CDR constructor))) ;1the BOA-constructor biz. laff, laff.*
))
;1;if no COPIER was spec'd, make a default.*
(IF (NOT (CAR copier))
(SETQ copier (READ-FROM-STRING
(CONCATENATE 'STRING "3COPY-*" (STRING name))))
;1;ELSE, if it was spec'd as NIL, don't do one at all*
(IF (CADR copier)
(SETQ copier (CADR copier))))
;1;if no PREDICATE was spec'd, make a default.*
(IF (NOT (CAR predicate))
(SETQ predicate (READ-FROM-STRING
(CONCATENATE 'STRING (STRING name) "3-P*")))
;1;ELSE, if it was spec'd as NIL, don't do one at all*
(IF (CADR predicate)
(SETQ predicate (CADR predicate))))
;1;if no CONC-NAME was spec'd, make a default.*
(IF (NOT (CAR conc-name))
(SETQ conc-name (READ-FROM-STRING
(CONCATENATE 'STRING (STRING name) "3-*")))
;1;ELSE, if it was spec'd as NIL, don't do one at all*
(IF (CADR conc-name)
(SETQ conc-name (CADR conc-name))))
;1;create the form to be returned*
`(PROGN
(defclass ,name
,includes
,(LET (doc type read-only)
(DOLIST (slot slots (SETQ temp (REVERSE temp)))
(SETQ type ()
doc ()
read-only ())
(IF (ATOM slot)
;1;THEN, it's a simple slot-spec. do the obvious things.*
(PUSH (LIST slot
:initform ()
:accessor (READ-FROM-STRING
(CONCATENATE 'STRING
(OR (STRING conc-name) "")
(STRING slot)))
:initarg (READ-FROM-STRING
(CONCATENATE 'STRING "3:*" (STRING slot)))
)
temp)
;1;ELSE, it's a complex slot-spec. just do the defined things.*
(IF (MEMBER :read-only slot)
(SETQ read-only t))
(IF (MEMBER :type slot)
(SETQ type t))
(IF (MEMBER :documentation slot)
(SETQ doc t))
(PUSH `(,(CAR slot)
:initform ,(CADR slot)
,(IF read-only :reader :accessor)
,(READ-FROM-STRING
(CONCATENATE 'STRING
(STRING conc-name)
(STRING (CAR slot))))
,@(IF type (LIST :type (CADR (MEMBER :type slot))))
,@(IF doc (LIST :documentation (CADR (MEMBER :documentation slot))))
:initarg ,(READ-FROM-STRING
(CONCATENATE 'STRING "3:*" (STRING (CAR slot)))))
temp)))
)
,(IF doc-str (LIST :documentation doc-str))
)
,@(TYPECASE constructor
(ATOM `((DEFUN ,constructor (&rest args)
(APPLY #'MAKE-INSTANCE ',name args)
)))
(LIST `((DEFUN ,(CAR constructor) ,(CADR constructor)
"3********************** THIS NEEDS HELP BAD !!! ***********************"
(APPLY #'MAKE-INSTANCE ',name args)
))
))
,@(IF copier
`((DEFUN ,copier (instance)
(COPY instance)
)))
,@(IF (AND predicate named)
`((DEFUN ,predicate (instance)
(TYPEP instance ',name)
)))
)))
`(,defstruct? ,name&options ,@slots)
))
;(4convert-defstruct-to-class*
; (DEFSTRUCT 4platform*
; route-xs route-ys ;1the route waypoints*
; footprint-points ;1corners of most recent footprint*
; PTLs-in-footprint ;1PTLs in most recent footprint*
; latest-sensor-angles ;1sensor angles of most recent footprint*
; current-waypoint ;1which waypoint we are in front of*
; x y ;1current location*
; (direction 0) ;1heading between current and approaching waypoints*
; roll pitch yaw
; velocity altitude))
;(4convert-defstruct-to-class*
; (DEFSTRUCT (clint :conc-name 'clint--
; (:constructor 'do-a-clint (a b c))
; :copier 'copy-a-clint
; :predicate 'is-it-a-clint
; :include 'hyde
; :print-function 'print-a-clint
;; :type 'VECTOR
; :named
;; :initial-offset 3
; )
; (slot1 10 :type :integer)
; (slot2 'aaa :read-only t :documentation "3Doc-string*")))
;1;; ********** ********** ********** ********** ********** ***********
;1;; ********** ********** ********** ********** ********** ***********
;1;; ********** ********** ********** ********** ********** ***********
;1;; END OF FILE convert-struct-to-class.*
;1;; ********** ********** ********** ********** ********** ***********
;1;; ********** ********** ********** ********** ********** ***********
;1;; ********** ********** ********** ********** ********** **********