) (02/08/90)
;;; -*- Mode:Common-Lisp; Fonts:(MEDFNT MEDFNTB HL12BI HL12B CPTFONTB); Base:10 -*-
;1;; if you've been faced with converting FLAVORs to CLOS,*
;1;; this stuff should help.*
;1;; it is by no means complete, or perfect, but it's a good headstart.*
;1;; for example, the stranger things of FLAVOR options are mostly *
;1;; or simply have no equivalent or are not here yet,*
;1;; nor are conversions of things inside METHODs.*
(DEFMACRO 4convert-flavor-to-class* ((ignore name IVs incl &body body)
&aux (temp ()) (defs ()) (doc ""))
"2Converts a FLAVOR definition into a CLASS definition.*"
(DOLIST (iv IVs (SETQ temp (REVERSE temp)))
(IF (ATOM iv)
(PUSH (LIST iv :initform ()) temp)
(PUSH (LIST (CAR iv) :initform
(IF (SYMBOLP (CADR iv))
(CADR iv)))
temp)))
(DOLIST (stuff body)
;1;fix up the things which are currently understood.*
(IF (LISTP stuff)
;1;THEN, it was a list of specific things.*
(CASE (CAR stuff)
;1; :gettable-IVs become :reader entries.*
(:gettable-instance-variables (DOLIST (iv (CDR stuff))
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
(LIST :reader IV)
))))
;1; :settable-IVs become :accessor entries.*
(:settable-instance-variables (DOLIST (iv (CDR stuff))
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
(LIST :accessor IV :initarg
(READ-FROM-STRING (FORMAT () "3:~S*" IV)))
))))
;1; :inittable-IVs become :initform entries.*
(:inittable-instance-variables (DOLIST (iv (CDR stuff))
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL iv (CAR tmp))))
(LIST :initarg (FORMAT () "3:~S*" IV))
))))
;1; the :default-init-plist behaves differently, because it*
;1; doesn't go into the IV slot def. it tacks on at the end,*
;1; in much the same way as with the flavor.*
(:default-init-plist (SETQ defs (LIST (CONS :default-initargs (CDR stuff)))))
(:REQUIRED-FLAVORS (SETQ incl (APPEND incl (CDR stuff))))
(:REQUIRED-INSTANCE-VARIABLES (SETQ IVs (APPEND IVs (CDR stuff))))
(:INCLUDED-FLAVORS (SETQ incl (APPEND incl (CDR stuff))))
(:DOCUMENTATION (SETQ doc (CDR stuff)))
)
;1;ELSE, it was an atomic item, meaning ALL IVs get this attribute.*
(CASE stuff
(:settable-instance-variables (DOLIST (iv IVs)
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
(LIST :accessor IV :initarg (FORMAT () "3:~S*" IV))
))))
(:inittable-instance-variables (DOLIST (iv IVs)
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
(LIST :initarg (FORMAT () "3:~S*" IV))
))))
(:gettable-instance-variables (DOLIST (iv IVs)
(SETF (NTH (POSITION iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
temp)
(APPEND (FIND iv temp :test #'(lambda (iv tmp)
(EQUAL (IF (LISTP iv)
(CAR iv)
iv)
(CAR tmp))))
(LIST :reader IV)
)))))
))
;1;if there's something else...*
;1;first remove all the things which were dealt with in the CASE.*
(DOLIST (r (LIST :inittable-instance-variables :default-init-plist
:gettable-instance-variables :settable-instance-variables
:REQUIRED-METHODS :REQUIRED-INSTANCE-VARIABLES
:DOCUMENTATION :INCLUDED-FLAVORS
))
;1;these items have no direct equivalent in CLOS.*
;1 * (:DEFAULT-HANDLER function)
; :NO-VANILLA-FLAVOR
; (:METHOD-ORDER m1 m2...)
; (:METHOD-COMBINATION (type order operation1 operation2...)...)
; (:SPECIAL-INSTANCE-VARIABLES <variables>)
; :ABSTRACT-FLAVOR
; :ALIAS-FLAVOR
;1;keep what remains*
(SETQ body (REMOVE r body :test #'(lambda (opt tmp)
(EQUAL opt (IF (LISTP tmp)
(CAR tmp)
tmp))))))
;1;return this*
`(defclass
,name
,incl
,temp
,@defs
,@(IF body
'("3This next bunch is still left from the Flavor def'n, and needs to be changed.*")
())
,@body)
)
;1;;a test case with variety.*
(COMMENT
print (convert-flavor-to-class
(DEFFLAVOR radio-button (center-x center-y radius window string (font ()) (on ())
left top right bottom (polygon (MAKE-ARRAY 60)))
()
(:gettable-instance-variables radius left top right bottom)
(:settable-instance-variables center-x center-y window string font on)
;1(:default-init-plist :string "")*
;1(:doodled-up things which do nowhere)*
;1(:doodled-up which nowhere things go)*
)
))
;1;;***********************************************************************
;1;;***********************************************************************
;1;;now to convert methods. this also converts instances of (SEND self :xx args)*
;1;; into (xx self args)*
(DEFMACRO 4convert-flav-meth-to-clos-meth* ((IGNORE name args &body body) &aux (doc-str ()))
;1;do the make-inst so that we can find all the slots.*
(IF (AND (NOT (GET (CAR name) 'sys:flavor)) ;1it's NOT a flavor*
(GET (CAR name) 'ticlos:class-def) ;1it IS a class*
)
(IF (NOT (ticlos:class-composed-p (find-class (CAR name)))) ;1it's already been composed.*
(MAKE-INSTANCE (CAR name)) ;1make an instance. this "composes" the class.*
)
(ERROR "3You need to compile the DEFCLASS first.
I can't convert methods until you do.*"))
;1;get the doc-str in the right place.*
(WHEN (STRINGP (CAR body))
(SETQ doc-str (LIST (CAR body)))
(SETQ body (CDR body)))
;1;now do the conversion.*
`(DEFMETHOD ,(IF (THIRD name) ;1the method-name*
(READ-FROM-STRING (SYMBOL-NAME (THIRD name)))
(READ-FROM-STRING (SYMBOL-NAME (SECOND name))))
,@(IF (THIRD name) ;1the daemon*
(READ-FROM-STRING (SYMBOL-NAME (SECOND name))))
,(CONS (LIST 'myself (FIRST name)) ;1self isn't right here, but will do for now.*
args) ;1the cons is for when args is NIL. couldn't do @.*
,@doc-str
,@(IF body
`((with-slots ,(MAPCAR #'(lambda (slot)
(LIST (ticlos:slot-name slot) (ticlos:slot-name slot)))
(class-slots (find-class (CAR name))))
myself
,@(convert-flav-send-self-walker body)))))
)
;1;;***********************************************************************
;1;; now for a code-walker with which to replace (SEND self ...) calls.*
(DEFUN 4convert-flav-send-self-walker *(body)
(MAPCAR #'(lambda (form)
(IF (LISTP form)
(IF (AND (EQUAL (CAR form) 'SEND)
(EQUAL (CADR form) 'self))
`(,(READ-FROM-STRING (SYMBOL-NAME (THIRD form)))
self
,@(CDDDR form))
(walk form)
)
form))
body))
;1;;***********************************************************************
;1;;***********************************************************************
;1;;a test case.*
(;COMMENT
convert-flav-meth-to-clos-meth
(DEFMETHOD (radio-button :setup) ()
(UNLESS font (SETQ font fonts:cptfont))
(UNLESS window (ERROR "3You didn't specify a window for this Radio-Button.*"))
(SETQ radius (- (FLOOR (/ (w:font-char-height font) 2)) 1)
left (- center-x radius 1)
right (+ center-x radius 1)
top (- center-y radius 1)
bottom (+ center-y radius 1)
)
)
)
;(convert-flav-meth-to-clos-meth
; (DEFMETHOD 4(radio-button :refresh)* ()
; ;1;do something to refresh the region*
; ;(SEND window :draw-circle center-x center-y radius 1 w:black w:normal 30)
; (tv:sheet-string-out-explicit-1 window string (+ center-x radius 4) (- center-y radius )
; () () font w:normal)
; (SEND self :draw-radio-button)
; )
; )
;(DEFMETHOD 4refresh* ((self radio-button))
; (with-slots ((center-x center-x) (center-y center-y) (radius radius) (window window)
; (STRING string) (font font) (on on) (left left) (top top) (right right)
; (bottom bottom) (polygon polygon)) self
; (tv::sheet-string-out-explicit-1 window string (+ center-x radius 4) (- center-y radius) nil
; nil font w:normal)
; (draw-radio-button self)))
;1;;***********************************************************************
;1;;***********************************************************************
;1;;***********************************************************************
;1;; END of file CONVERT-FLAV-TO-CLASS*
;1;;***********************************************************************
;1;;***********************************************************************
;1;;**********************************************************************