;;; obj/meta/pkg.lisp --- Meta-objects

 ;;

 ;;; Commentary:

 ;;;; Notes:

 ;; ordered? https://www.reddit.com/r/lisp/comments/n88x59/metaclasses_using_structures_or_speeding_up_slot/

 ;;;; Ref:

 ;; https://franz.com/support/documentation/11.0/mop/concepts.html

 ;;; Code:

 (defpackage :obj/meta/stealth

   (:use :cl :std :obj/meta :sb-mop))

 (defpackage :obj/meta/typed

   (:use :cl :std :obj/meta :sb-mop))

 (defpackage :obj/meta/filtered

   (:use :cl :std :obj/meta :sb-mop)

   (:export

    :define-filtered-function :filtered :filtered-function :filtered-method

    :generic-function-filter-expression :generic-function-filters :method-filter :simple-filtered-function))

 (defpackage :obj/meta/sealed

   (:use :cl :std :obj/meta)

   (:import-from :sb-pcl :eql-specializer :intern-eql-specializer

    :eql-specializer-object :funcallable-standard-class)

   (:import-from :sb-mop :class-finalized-p :finalize-inheritance

    :class-precedence-list :class-direct-superclasses :specializer :method-specializers

    :generic-function-argument-precedence-order :generic-function-name :generic-function-methods :class-direct-subclasses

    :class-prototype)

   (:export

    :ensure-specializer

    :specializer-type

    :specializer-prototype

    :specializer-direct-superspecializers

    :specializer-intersectionp

    :specializer-subsetp

    :domain

    :ensure-domain

    :method-domain

    :domain-specializers

    :domain-arity

    :domain-equal

    :domain-intersectionp

    :domain-subsetp

    :metaobject-sealable-p

    :class-sealable-p

    :generic-function-sealable-p

    :method-sealable-p

    :specializer-sealable-p

    :metaobject-sealed-p

    :class-sealed-p

    :generic-function-sealed-p

    :method-sealed-p

    :specializer-sealed-p

    :seal-class

    :seal-generic-function

    :seal-method

    :seal-domain

    :seal-specializer

    :method-properties

    :validate-method-property

    :static-call-signature

    :static-call-signature-types

    :static-call-signature-prototypes

    :sealed-domains

    :compute-static-call-signatures

    :externalizable-object-p

    :sealable-class

    :sealable-generic-function

    :sealable-standard-generic-function

    :potentially-sealable-method

    :potentially-sealable-standard-method))

 (defpackage :obj/meta/fast

   (:use :cl :std :obj/meta/sealed :obj/meta)

   (:import-from :sb-int :gensymify)

   (:import-from :sb-walker :macroexpand-all)

   (:export :fast-generic-function :fast-method :inlineable))

 (defpackage :obj/meta/lazy

   (:use :cl :std :obj/meta))

 (defpackage :obj/meta/overloaded

   (:use :cl :std :obj/meta))

 (defpackage :obj/meta/storable

   (:use :cl :std :obj/meta :obj/id)

   (:export

    :storable-class :initialize-storable-class

    :storable-slot-mixin :storable-direct-slot-definition

    :storable-effective-slot-definition))

 (in-package :obj/meta)

 (defun class-equalp (c1 c2)

   (when (symbolp c1) (setf c1 (find-class c1)))

   (when (symbolp c2) (setf c2 (find-class c2)))

   (eq c1 c2))

 (defun type-specifier-and (&rest type-specifiers)

   (let ((relevant (remove t type-specifiers)))

     (cond ((null relevant) t)

           ((null (cdr relevant)) (first relevant))

           (t `(and ,@relevant)))))

 (defun type-specifier-or (&rest type-specifiers)

   (let ((relevant (remove nil type-specifiers)))

     (cond ((null relevant) nil)

           ((null (cdr relevant)) (first relevant))

           (t `(or ,@relevant)))))

 (defun type-specifier-not (type-specifier)

   (cond ((eql type-specifier t) nil)

         ((eql type-specifier nil) t)

         (t `(not ,type-specifier))))

 (defparameter *standard-metaobjects*

   (list (find-class 'standard-object)

         (find-class 'standard-class)

         (find-class 'standard-generic-function)

         (find-class 'standard-method)

         (find-class 'built-in-class)))

 ;;; From ARNESI - Messing with the MOP

 ;; https://bese.common-lisp.dev/docs/arnesi/html/Messing_0020with_0020the_0020MOP.html#wrapping-standard_0020method_0020combination

 (define-method-combination wrapping-standard

     (&key (around-order :most-specific-first)

           (before-order :most-specific-first)

           (primary-order :most-specific-first)

           (after-order :most-specific-last)

           (wrapping-order :most-specific-last)

           (wrap-around-order :most-specific-last))

   ((wrap-around (:wrap-around))

    (around (:around))

    (before (:before))

    (wrapping (:wrapping))

    (primary () :required t)

    (after (:after)))

   "Same semantics as standard method combination but allows

 \"wrapping\" methods. Ordering of methods:

  (wrap-around

    (around

      (before)

      (wrapping

        (primary))

      (after)))

 :warp-around, :around, :wrapping and :primary methods call the

 next least/most specific method via call-next-method (as in

 standard method combination).

 The various WHATEVER-order keyword arguments set the order in

 which the methods are called and be set to either

 :most-specific-last or :most-specific-first."

   (labels ((effective-order (methods order)

              (ecase order

                (:most-specific-first methods)

                (:most-specific-last (reverse methods))))

            (call-methods (methods)

              (mapcar (lambda (meth) `(call-method ,meth))

                      methods)))

     (let* (;; reorder the methods based on the -order arguments

            (wrap-around (effective-order wrap-around wrap-around-order))

            (around (effective-order around around-order))

            (wrapping (effective-order wrapping wrapping-order))

            (before (effective-order before before-order))

            (primary (effective-order primary primary-order))

            (after (effective-order after after-order))

            ;; inital value of the effective call is a call its primary

            ;; method(s)

            (form (case (length primary)

                    (1 `(call-method ,(first primary)))

                    (t `(call-method ,(first primary) ,(rest primary))))))

       (when wrapping

         ;; wrap form in call to the wrapping methods

         (setf form `(call-method ,(first wrapping)

                                  (,@(rest wrapping) (make-method ,form)))))

       (when before

         ;; wrap FORM in calls to its before methods

         (setf form `(progn

                       ,@(call-methods before)

                       ,form)))

       (when after

         ;; wrap FORM in calls to its after methods

         (setf form `(multiple-value-prog1

                         ,form

                       ,@(call-methods after))))

       (when around

         ;; wrap FORM in calls to its around methods

         (setf form `(call-method ,(first around)

                                  (,@(rest around)

                                     (make-method ,form)))))

       (when wrap-around

         (setf form `(call-method ,(first wrap-around)

                                  (,@(rest wrap-around)

                                     (make-method ,form)))))

       form)))