changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/mop.lisp

changeset 698: 96958d3eb5b0
parent: a36280d2ef4e
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; std/mop.lisp --- Standard MOP Utilities
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :std/mop)
     7 
     8 ;; make-specializer-form-using-class
     9 ;; make-method-lambda-using-specializers
    10 
    11 (defun list-indirect-class-methods (class)
    12   "List all indirect methods of CLASS."
    13   (remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class))))
    14 
    15 (defun list-class-methods (class methods &optional indirect)
    16   "List all methods specializing on CLASS modulo METHODS. When INDIRECT is
    17 non-nil, also include indirect (parent) methods."
    18   (if (eq methods t)
    19       (if indirect
    20           (list-indirect-class-methods class)
    21           (specializer-direct-generic-functions class))
    22       (mapcar
    23        (lambda (s)
    24          (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name)))
    25        methods)))
    26 
    27 ;; FIX 2023-09-13: need exclude param
    28 (defun list-class-slots (class slots &optional exclude)
    29   ;; should probably convert slot-definition-name here
    30   (let ((cs (remove-if
    31              (lambda (s)
    32                (or
    33                 (null s)
    34                 (member t (mapcar
    35                            (lambda (x)
    36                              (string= (slot-definition-name s) x))
    37                            exclude))))
    38              (class-slots class))))
    39     (if (eq slots t)
    40         cs
    41         (loop for s in slots
    42               with sn = (symb s)
    43               for c in cs
    44               with cn = (symb (slot-definition-name c))
    45               when (eq sn cn)
    46                 collect c))))
    47 
    48 ;; TODO 2023-09-09: slot exclusion from dynamic var
    49 (defun list-slot-values-using-class (class obj slots &optional nullp unboundp)
    50   (remove-if
    51    #'null
    52    (mapcar
    53     (lambda (s)
    54       (let ((n (slot-definition-name s)))
    55         (let ((ns (make-keyword (symbol-name n))))
    56           (if (slot-boundp-using-class class obj s)
    57               (let ((v (slot-value-using-class class obj s)))
    58                 (if nullp
    59                     `(,ns ,v)
    60                     (unless (null v)
    61                       `(,ns ,v))))
    62               (when unboundp (list ns))))))
    63     slots)))
    64 
    65 ;; closer-mop
    66 (defun ensure-finalized (class &optional (errorp t))
    67   (if (typep class 'class)
    68     (unless (class-finalized-p class)
    69       (finalize-inheritance class))
    70     (when errorp (error "~S is not a class." class)))
    71   class)
    72 
    73 (defun subclassp (class superclass)
    74   (flet ((get-class (class) (etypecase class
    75                               (class class)
    76                               (symbol (find-class class)))))
    77 
    78       (loop with class = (get-class class)
    79             with superclass = (get-class superclass)
    80 
    81             for superclasses = (list class)
    82             then (set-difference
    83                   (union (class-direct-superclasses current-class) superclasses)
    84                   seen)
    85 
    86             for current-class = (first superclasses)
    87 
    88             while current-class
    89 
    90             if (eq current-class superclass) return t
    91             else collect current-class into seen
    92 
    93             finally (return nil))))