🚀 go-pugleaf

;;; -*- 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;; ********** ********** ********** ********** ********** **********