changeset 694: |
a36280d2ef4e |
parent: |
8fe057887c17
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Thu, 03 Oct 2024 21:54:07 -0400 |
permissions: |
-rw-r--r-- |
description: |
tasks |
1 ;;; std/mop.lisp --- Standard MOP Utilities 8 ;; make-specializer-form-using-class 9 ;; make-method-lambda-using-specializers 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)))) 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." 20 (list-indirect-class-methods class) 21 (specializer-direct-generic-functions class)) 24 (car (member s (specializer-direct-generic-functions class) :key #'generic-function-name))) 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 36 (string= (slot-definition-name s) x)) 38 (class-slots class)))) 44 with cn = (symb (slot-definition-name c)) 48 ;; TODO 2023-09-09: slot exclusion from dynamic var 49 (defun list-slot-values-using-class (class obj slots &optional nullp unboundp) 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))) 62 (when unboundp (list ns)))))) 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))) 73 (defun subclassp (class superclass) 74 (flet ((get-class (class) (etypecase class 76 (symbol (find-class class))))) 78 (loop with class = (get-class class) 79 with superclass = (get-class superclass) 81 for superclasses = (list class) 83 (union (class-direct-superclasses current-class) superclasses) 86 for current-class = (first superclasses) 90 if (eq current-class superclass) return t 91 else collect current-class into seen 93 finally (return nil))))