Plaster
New
List
Login
text
default
anonymous
2022.01.05 18:40:51
;;;;**************************************************************************** ;;;; -*- coding:utf-8 -*- ;;;; Author: Ashok Khanna ;;;; License: AGPL3 ;;;; ;;;; Copyright Ashok Khanna 2020 - 2021 ;;;; ;;;; This program is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU Affero General Public License as published by ;;;; the Free Software Foundation, either version 3 of the License, or ;;;; (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU Affero General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Affero General Public License ;;;; along with this program. If not, see <http://www.gnu.org/licenses/> ;;;;**************************************************************************** (defpackage "COM.MATHQL.LISP.ASHOK.CLASS" (:use "COMMON-LISP") (:nicknames "ASHOK.CLASS") (:documentation "This package provides core utilities for class creation and manipulation.")) (in-package "COM.MATHQL.LISP.ASHOK.CLASS") ;;;;**************************************************************************** (defun classp (a) "Return t if A is an instance of standard class and nil otherwise." (typep a 'standard-object)) (defun not-class-p (a) "Return t if A is not an instance of standard class and nil otherwise." (not (classp a))) (defun type-equal (a b) "Return t if A and B have the same type and nill otherwise." (equal (type-of a) (type-of b))) (defun not-type-equal (a b) "Return t if A and B do not have the same type and nil otherwise." (not (type-equal a b))) ;;; - - - - - - - - - - - - - - - - - - - - ;;; Convenience Wrappers around Closer Mop (defun slot-boundp-using-class (a slot) "SLOT-BOUNDP for instance A and slot SLOT, using CLOSER-MOP." (closer-mop:slot-boundp-using-class (type-of a) a slot)) (defun slot-value-using-class (a slot) "SLOT-VALUE for instance A and slot SLOT, using CLOSER-MOP." (closer-mop:slot-value-using-class (type-of a) a slot)) (defun get-class-slots (a) "Return the slots of instance A using CLOSER-MOP." (closer-mop:class-slots (find-class (type-of a)))) (defun get-shared-slot-value (class slot) "Return the slot value of shared SLOT for CLASS." (closer-mop::slot-value (closer-mop:class-prototype (find-class class)) slot)) ;;; - - - - - - - - - - - - - - - - - - - - ;;; Class Equality (defun class-equal (a b &key (excluded-slots excluded-slots)) "Test equality of A and B based on comparing slot values with EQUALP, but treating any EXCLUDED-SLOTS as automatically equal." (cond ((not-type-equal a b) nil) ((not-class-p a) (equalp a b)) (t (all-slots-equal a b :excluded-slots excluded-slots)))) (defun all-slots-equal (a b &key (excluded-slots nil)) "Return t if equivalent slots of A and B are EQUALP to each other and nil otherwise. A and B must be of the same standard class. Treat any EXCLUDED-SLOTS as automatically equal." (let ((slot-list (get-class-slots a))) (every #'identity (mapcar #'(lambda (slot) (if (find (closer-mop:slot-definition-name slot) excluded-slots) t (slot-equal slot a b))) slot-list)))) (defun slot-equal (slot a b) "Return t if A and B are CLASS-EQUAL and nil otherwise." (when (and (slot-boundp-using-class a slot) (slot-boundp-using-class b slot)) (class-equal (slot-value-using-class a slot) (slot-value-using-class b slot)))) (defmacro defclass% (class-name docstring &rest slots) "Generate a DEFCLASS form with CLASS-NAME and SLOTS with ACCESSOR NAME = SLOT-NAME." (let ((make-symbol (intern (ashok.string:concat "MAKE-" (symbol-name class-name)))) (slot-forms (loop for slot in slots collect (cond ((listp slot) (list (car slot) :accessor (car slot) :initarg (intern (symbol-name (car slot)) "KEYWORD") :initform `',(cdr slot))) (t (list slot :accessor slot :initarg (intern (symbol-name slot) "KEYWORD"))))))) `(progn (defclass ,class-name () ,slot-forms (:documentation ,docstring)) (defmacro ,make-symbol (&rest slot-names) `(make-instance ',',class-name ,@slot-names))))) (defmacro defclass%% (class-name docstring &rest slots) "Generate a DEFCLASS form with CLASS-NAME and SLOTS with ACCESSOR NAME = CLASS-NAME-SLOT-NAME." (let ((make-symbol (intern (ashok.string:concat "MAKE-" (symbol-name class-name)))) (slot-forms (loop for slot in slots collect (cond ((listp slot) (list (car slot) :accessor (intern (ashok.string:concat (symbol-name class-name) "-" (symbol-name (car slot)))) :initarg (intern (symbol-name (car slot)) "KEYWORD") :initform `',(cdr slot))) (t (list slot :accessor (intern (ashok.string:concat (symbol-name class-name) "-" (symbol-name slot))) :initarg (intern (symbol-name slot) "KEYWORD"))))))) `(progn (defclass ,class-name () ,slot-forms (:documentation ,docstring)) (defmacro ,make-symbol (&rest slot-names) `(make-instance ',',class-name ,@slot-names))))) ;;;;**************************************************************************** ;;; Export all symbols from this package (mapc #'export (ashok.introspect:all-fboundp-symbols-in-package))
Raw
Annotate
Repaste
Edit