Starting MOP code.
This commit is contained in:
parent
ca7fb58b38
commit
0cda04e9e3
|
@ -0,0 +1,42 @@
|
||||||
|
;;;; kmop.lisp
|
||||||
|
|
||||||
|
(in-package #:kutils-mop)
|
||||||
|
|
||||||
|
;;; metaobject interactions
|
||||||
|
|
||||||
|
(defun get-class-initargs (slots)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(defun get-all-init-args (class-sym &optional (package *package*))
|
||||||
|
(let ((class-val (find-class
|
||||||
|
(find-symbol
|
||||||
|
(mkstr class-sym)
|
||||||
|
package))))
|
||||||
|
(when class-val
|
||||||
|
(closer-mop:ensure-finalized class-val)
|
||||||
|
(flatten
|
||||||
|
(remove-if (lambda (slot)
|
||||||
|
(null (closer-mop:slot-definition-initargs slot)))
|
||||||
|
(closer-mop:class-slots class-val))))))
|
||||||
|
|
||||||
|
(defun kw-key (kw)
|
||||||
|
(string-downcase
|
||||||
|
(mkstr kw)))
|
||||||
|
|
||||||
|
(defun dispatch-get-value (value))
|
||||||
|
|
||||||
|
|
||||||
|
(defun zip-initargs-hash-table (args ht)
|
||||||
|
(flatten
|
||||||
|
(mapcar (lambda (slot)
|
||||||
|
(list slot (gethash (kw-key slot) ht)))
|
||||||
|
args)))
|
||||||
|
|
||||||
|
(defun make-instance-from-hash-table (class-type table &optional (package *package*))
|
||||||
|
(let ((class-sym (find-class class-type)))
|
||||||
|
(when class-sym
|
||||||
|
(apply #'make-instance class-sym
|
||||||
|
(zip-initargs-hash-table
|
||||||
|
(get-all-init-args class-type package)
|
||||||
|
table)))))
|
|
@ -0,0 +1,4 @@
|
||||||
|
;;;; package.lisp
|
||||||
|
|
||||||
|
(defpackage #:kutils-mop
|
||||||
|
(:use #:cl #:kutils))
|
|
@ -0,0 +1,11 @@
|
||||||
|
;;;; kutils-mop.asd
|
||||||
|
|
||||||
|
(asdf:defsystem #:kutils-mop
|
||||||
|
:description "Kyle's MOP utilities."
|
||||||
|
:author "K. Isom <kyle@metacircular.net>"
|
||||||
|
:license "MIT License"
|
||||||
|
:serial t
|
||||||
|
:depends-on (#:closer-mop #:kutils)
|
||||||
|
:components ((:file "kmop/package")
|
||||||
|
(:file "kmop/kmop")))
|
||||||
|
|
Loading…
Reference in New Issue