changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/mop.lisp

changeset 387: 8252ee515756
parent: 8fe057887c17
child: a36280d2ef4e
author: Richard Westhaver <ellis@rwest.io>
date: Thu, 30 May 2024 18:31:53 -0400
permissions: -rw-r--r--
description: db and readtables 
     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)))