Defstruct and Defclass as macros

The SBCL version

(macroexpand-1 '(defstruct spoint (x y)))

(PROGN
 (SB-KERNEL:WITH-SINGLE-PACKAGE-LOCKED-ERROR (:SYMBOL 'SPOINT
                                              "defining ~A as a structure"))
 (SB-KERNEL::%DEFSTRUCT '#
                        '#(#
                           #)
                        (SB-C:SOURCE-LOCATION))
 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
   (SB-KERNEL::%COMPILER-DEFSTRUCT '#
                                   '#(#
                                      #)))
 (DECLAIM (FTYPE (SB-INT:SFUNCTION (&KEY (:X T)) SPOINT) MAKE-SPOINT))
 (DEFUN MAKE-SPOINT (&KEY ((:X #:DUM947) Y))
   (SB-KERNEL::%MAKE-STRUCTURE-INSTANCE-MACRO
    # '((:SLOT T . 1)) #:DUM947))
 (LOCALLY
  (DECLARE (NOTINLINE SB-KERNEL:FIND-CLASSOID))
  (SETF (SB-KERNEL::STRUCTURE-CLASSOID-CONSTRUCTOR
         (SB-KERNEL:FIND-CLASSOID 'SPOINT))
          #'MAKE-SPOINT))
 'SPOINT)

(macroexpand-1 '(defclass point () (x y)))

(PROGN
 (EVAL-WHEN (:COMPILE-TOPLEVEL)
   (SB-PCL::%COMPILER-DEFCLASS 'POINT 'NIL 'NIL '(Y X)))
 (EVAL-WHEN (:LOAD-TOPLEVEL :EXECUTE)
   (LET ()
     (SB-PCL::LOAD-DEFCLASS 'POINT 'STANDARD-CLASS 'NIL
                            (LIST
                             (LIST* :NAME 'X :READERS 'NIL :WRITERS 'NIL
                                    :INITARGS 'NIL 'NIL)
                             (LIST* :NAME 'Y :READERS 'NIL :WRITERS 'NIL
                                    :INITARGS 'NIL 'NIL))
                            (LIST :DIRECT-DEFAULT-INITARGS NIL) 'NIL 'NIL
                            '(Y X) (SB-C:SOURCE-LOCATION) 'NIL))))

The Allegro CL version

(macroexpand-1 '(defstruct spoint (x y)))

(PROGN (PROGN (EVAL-WHEN (COMPILE)
                (EXCL::CHECK-LOCK-DEFINITIONS-COMPILE-TIME 'SPOINT :TYPE 'DEFSTRUCT (SYSTEM:CE-GET 'SPOINT 'EXCL::%STRUCTURE-DEFINITION)))
              (EVAL-WHEN (LOAD EVAL) (EXCL::CHECK-LOCK-DEF-DEFSTRUCT 'SPOINT)) (RECORD-SOURCE-FILE 'SPOINT :TYPE :TYPE))
       (PROGN (EVAL-WHEN (COMPILE) (PUSH 'SPOINT-X EXCL::.FUNCTIONS-DEFINED.)) (RECORD-SOURCE-FILE 'SPOINT-X)
              (SETF (SYMBOL-FUNCTION 'SPOINT-X) (EXCL::GET-BUILT-IN-ACCESSOR 1)))
       (DEFSETF SPOINT-X EXCL::DEFSTRUCT-SLOT-DEFSETF-HANDLER 1) (DEFUN MAKE-SPOINT (&KEY (#:X Y)) (SYSTEM::NEW-STRUCT 'SPOINT #:X))
       (DEFINE-COMPILER-MACRO MAKE-SPOINT (&WHOLE EXCL::WHOLE &REST REST)
         (LET ((EXCL::INITS #)) (IF EXCL::INITS (EXCL::BQ-LIST `LET* EXCL::INITS #) EXCL::WHOLE)))
       (EXCL::DEFINEF COPY-SPOINT (SYMBOL-FUNCTION 'COPY-STRUCTURE)) (EXCL::DEFINEF SPOINT-P (EXCL::GET-DD-PREDICATE-CLOSURE 'SPOINT))
       (EVAL-WHEN (LOAD EVAL)
         (LET ((EXCL::NEW #))
           (EXCL::COMPUTE-STRUCT-CPL EXCL::NEW)
           (EXCL::NOTIFY-CLOS-OF-NEW-STRUCTURE 'SPOINT EXCL::NEW)
           (EVAL-WHEN (LOAD EVAL) (SETF # EXCL::NEW))))
       (EVAL-WHEN (COMPILE)
         (LET ((EXCL::OLD #) (EXCL::NEW #))
           (SETF (EXCL::DD-INCLUDED-BY EXCL::NEW) (IF EXCL::OLD #))
           (EXCL::COMPUTE-STRUCT-CPL EXCL::NEW)
           (EXCL::NOTIFY-CLOS-OF-NEW-STRUCTURE 'SPOINT EXCL::NEW SYSTEM:*COMPILATION-UNIT-ENVIRONMENT*)
           (SYSTEM:CE-PUTPROP 'SPOINT EXCL::NEW 'EXCL::%STRUCTURE-DEFINITION)))
       ...)

(macroexpand-1 '(defclass point () (x y)))

(PROGN NIL (EVAL-WHEN (COMPILE) (EXCL::CHECK-LOCK-DEFINITIONS-COMPILE-TIME 'POINT :TYPE 'DEFCLASS (FIND-CLASS 'POINT NIL)))
       (RECORD-SOURCE-FILE 'POINT :TYPE :TYPE)
       (EXCL::ENSURE-CLASS-1 'POINT :DIRECT-SUPERCLASSES 'NIL :DIRECT-SLOTS (LIST (LIST ':NAME 'X) (LIST ':NAME 'Y))))

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s