changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/obj/meta/pkg.lisp

changeset 356: aac665e2f5bf
parent: ac705fd55056
child: 9eb2c112aa16
author: Richard Westhaver <ellis@rwest.io>
date: Tue, 21 May 2024 17:13:34 -0400
permissions: -rw-r--r--
description: stashed and revert some obj/color changes. added x/wayland feature splits, WITH-TCP-CLIENT and WITH-UDP-CLIENT impl (no tests) 
     1 ;;; obj/meta/pkg.lisp --- Meta-objects
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (defpackage :obj/meta/stealth
     7   (:use :cl :std :obj/meta :sb-mop))
     8 
     9 (defpackage :obj/meta/typed
    10   (:use :cl :std :obj/meta :sb-mop))
    11 
    12 (defpackage :obj/meta/filtered
    13   (:use :cl :std :obj/meta :sb-mop)
    14   (:export
    15    :define-filtered-function :filtered :filtered-function :filtered-method
    16    :generic-function-filter-expression :generic-function-filters :method-filter :simple-filtered-function))
    17 
    18 (defpackage :obj/meta/sealed
    19   (:use :cl :std :obj/meta)
    20   (:import-from :sb-pcl :eql-specializer :intern-eql-specializer
    21    :eql-specializer-object :funcallable-standard-class)
    22   (:import-from :sb-mop :class-finalized-p :finalize-inheritance
    23    :class-precedence-list :class-direct-superclasses :specializer :method-specializers
    24    :generic-function-argument-precedence-order :generic-function-name :generic-function-methods :class-direct-subclasses
    25    :class-prototype)
    26   (:export
    27    :ensure-specializer
    28    :specializer-type
    29    :specializer-prototype
    30    :specializer-direct-superspecializers
    31    :specializer-intersectionp
    32    :specializer-subsetp
    33    :domain
    34    :ensure-domain
    35    :method-domain
    36    :domain-specializers
    37    :domain-arity
    38    :domain-equal
    39    :domain-intersectionp
    40    :domain-subsetp
    41 
    42    :metaobject-sealable-p
    43    :class-sealable-p
    44    :generic-function-sealable-p
    45    :method-sealable-p
    46    :specializer-sealable-p
    47 
    48    :metaobject-sealed-p
    49    :class-sealed-p
    50    :generic-function-sealed-p
    51    :method-sealed-p
    52    :specializer-sealed-p
    53 
    54    :seal-class
    55    :seal-generic-function
    56    :seal-method
    57    :seal-domain
    58    :seal-specializer
    59 
    60    :method-properties
    61    :validate-method-property
    62 
    63    :static-call-signature
    64    :static-call-signature-types
    65    :static-call-signature-prototypes
    66 
    67    :sealed-domains
    68    :compute-static-call-signatures
    69    :externalizable-object-p
    70    :sealable-class
    71    :sealable-generic-function
    72    :sealable-standard-generic-function
    73    :potentially-sealable-method
    74    :potentially-sealable-standard-method))
    75 
    76 (defpackage :obj/meta/fast
    77   (:use :cl :std :obj/meta/sealed :obj/meta)
    78   (:import-from :sb-int :gensymify)
    79   (:import-from :sb-walker :macroexpand-all)
    80   (:export :fast-generic-function :fast-method :inlineable))
    81 
    82 (defpackage :obj/meta/lazy
    83   (:use :cl :std :obj/meta))
    84 
    85 (defpackage :obj/meta/overloaded
    86   (:use :cl :std :obj/meta))
    87 
    88 (in-package :obj/meta)
    89 
    90 (defun class-equalp (c1 c2)
    91   (when (symbolp c1) (setf c1 (find-class c1)))
    92   (when (symbolp c2) (setf c2 (find-class c2)))
    93   (eq c1 c2))
    94 
    95 (defun type-specifier-and (&rest type-specifiers)
    96   (let ((relevant (remove t type-specifiers)))
    97     (cond ((null relevant) t)
    98           ((null (cdr relevant)) (first relevant))
    99           (t `(and ,@relevant)))))
   100 
   101 (defun type-specifier-or (&rest type-specifiers)
   102   (let ((relevant (remove nil type-specifiers)))
   103     (cond ((null relevant) nil)
   104           ((null (cdr relevant)) (first relevant))
   105           (t `(or ,@relevant)))))
   106 
   107 (defun type-specifier-not (type-specifier)
   108   (cond ((eql type-specifier t) nil)
   109         ((eql type-specifier nil) t)
   110         (t `(not ,type-specifier))))
   111 
   112 (defparameter *standard-metaobjects*
   113   (list (find-class 'standard-object)
   114         (find-class 'standard-class)
   115         (find-class 'standard-generic-function)
   116         (find-class 'standard-method)
   117         (find-class 'built-in-class)))
   118 
   119 ;;; From ARNESI - Messing with the MOP
   120 
   121 ;; https://bese.common-lisp.dev/docs/arnesi/html/Messing_0020with_0020the_0020MOP.html#wrapping-standard_0020method_0020combination
   122 
   123 (define-method-combination wrapping-standard
   124     (&key (around-order :most-specific-first)
   125           (before-order :most-specific-first)
   126           (primary-order :most-specific-first)
   127           (after-order :most-specific-last)
   128           (wrapping-order :most-specific-last)
   129           (wrap-around-order :most-specific-last))
   130   ((wrap-around (:wrap-around))
   131    (around (:around))
   132    (before (:before))
   133    (wrapping (:wrapping))
   134    (primary () :required t)
   135    (after (:after)))
   136   "Same semantics as standard method combination but allows
   137 \"wrapping\" methods. Ordering of methods:
   138 
   139  (wrap-around
   140    (around
   141      (before)
   142      (wrapping
   143        (primary))
   144      (after)))
   145 
   146 :warp-around, :around, :wrapping and :primary methods call the
   147 next least/most specific method via call-next-method (as in
   148 standard method combination).
   149 
   150 The various WHATEVER-order keyword arguments set the order in
   151 which the methods are called and be set to either
   152 :most-specific-last or :most-specific-first."
   153   (labels ((effective-order (methods order)
   154              (ecase order
   155                (:most-specific-first methods)
   156                (:most-specific-last (reverse methods))))
   157            (call-methods (methods)
   158              (mapcar (lambda (meth) `(call-method ,meth))
   159                      methods)))
   160     (let* (;; reorder the methods based on the -order arguments
   161            (wrap-around (effective-order wrap-around wrap-around-order))
   162            (around (effective-order around around-order))
   163            (wrapping (effective-order wrapping wrapping-order))
   164            (before (effective-order before before-order))
   165            (primary (effective-order primary primary-order))
   166            (after (effective-order after after-order))
   167            ;; inital value of the effective call is a call its primary
   168            ;; method(s)
   169            (form (case (length primary)
   170                    (1 `(call-method ,(first primary)))
   171                    (t `(call-method ,(first primary) ,(rest primary))))))
   172       (when wrapping
   173         ;; wrap form in call to the wrapping methods
   174         (setf form `(call-method ,(first wrapping)
   175                                  (,@(rest wrapping) (make-method ,form)))))
   176       (when before
   177         ;; wrap FORM in calls to its before methods
   178         (setf form `(progn
   179                       ,@(call-methods before)
   180                       ,form)))
   181       (when after
   182         ;; wrap FORM in calls to its after methods
   183         (setf form `(multiple-value-prog1
   184                         ,form
   185                       ,@(call-methods after))))
   186       (when around
   187         ;; wrap FORM in calls to its around methods
   188         (setf form `(call-method ,(first around)
   189                                  (,@(rest around)
   190                                     (make-method ,form)))))
   191       (when wrap-around
   192         (setf form `(call-method ,(first wrap-around)
   193                                  (,@(rest wrap-around)
   194                                     (make-method ,form)))))
   195       form)))