| e143b109 |
(in-package #:fwoar.lisputils)
(defmacro with-accessors* ((&rest accessors) object &body body)
`(with-accessors ,(ensure-mapping accessors) ,object
,@body))
|
| c67ed088 |
|
| 8decda77 |
(defmacro keys ((op &rest args))
(multiple-value-bind (positional keywords) (split-at '&key args)
`(,op
,@positional
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
(cdr keywords)))))
|
| c67ed088 |
(defmacro new (class &rest initializer-syms)
(multiple-value-bind (required optional rest) (parse-ordinary-lambda-list initializer-syms)
(when optional
(error "new doesn't handle optional arguments"))
(if rest
`(make-instance ,class
|
| 6ad0acec |
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
|
| c67ed088 |
required)
,(make-keyword rest) ,rest)
`(make-instance ,class
|
| 6ad0acec |
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
|
| c67ed088 |
initializer-syms)))))
|
| e04c492f |
(defmacro defclass+ (name (&rest super) &body (direct-slots &rest options))
|
| 114e9cc5 |
(let (constructor-type defclass-options)
(mapc (lambda (option)
(case (car option)
((:constructor-type) (setf constructor-type (cadr option)))
(t (push option defclass-options))))
options)
(let* ((initargs (append (mapcan (lambda (class)
(typecase class
(cons (mapcar (lambda (it)
(list it nil))
(cadr class)))
(t nil)))
super)
(mapcan (lambda (slot)
(alexandria:ensure-list
(alexandria:when-let ((initarg (getf (cdr slot)
:initarg)))
(fw.lu:prog1-bind
(it (list
(list (intern (symbol-name initarg))
(eq :missing
(getf (cdr slot)
:initform
:missing)))))))))
direct-slots))))
(destructuring-bind (required optional)
(loop for it in initargs
if (second it) collect (first it) into required
else collect (first it) into optional
finally (return (list required
optional)))
(let ((passed-args (mapcar (lambda (it)
(intern (concatenate 'string
(symbol-name it)
"-P")))
optional)))
`(progn (defclass ,name
,(mapcar (lambda (it)
(typecase it
(cons (car it))
(t it)))
super)
,direct-slots
,@(nreverse defclass-options))
(defun ,name (,@required ,@(when optional
(list* '&optional
(mapcar (lambda (it it-p)
`(,it nil ,it-p))
optional
passed-args))))
(declare (optimize (speed 3) (debug 1)))
,(if optional
(let ((heads (reverse (inits optional))))
`(cond ,@(mapcar (lambda (it it-p)
`(,it-p (fw.lu:new ',name ,@required ,@it)))
heads
passed-args)
(t (fw.lu:new ',name ,@required))))
`(fw.lu:new ',name ,@required ,@optional)))))))))
|
| e04c492f |
|
| c67ed088 |
(defun-ct %constructor-name (class)
|
| 114e9cc5 |
(let ((*print-case* (readtable-case *readtable*)))
(format nil "~a-~a" '#:make class)))
|
| c67ed088 |
(defmacro make-constructor (class &rest args)
(destructuring-bind (class &optional (constructor-name (intern (%constructor-name class))))
(ensure-list class)
`(defgeneric ,constructor-name (,@args)
(:method (,@args)
(new ',class ,@args)))))
|
| ea2e6a55 |
(defclass hashtable-slot-mixin ()
((%doc :reader hsm-doc :initarg :doc)))
(defmethod c2mop:slot-value-using-class :before (class (object hashtable-slot-mixin) slotd)
(let ((slot-name (c2mop:slot-definition-name slotd)))
(unless (or (eql slot-name '%doc)
(c2mop:slot-boundp-using-class class object slotd))
(let* ((doc (hsm-doc object))
(doc-value (gethash (substitute #\_ #\-
(string-downcase
(symbol-name slot-name)))
doc)))
(setf (slot-value object slot-name) doc-value)))))
|
| 52df84af |
(defmacro define-printer (class &body options)
(alexandria:with-gensyms (s)
`(defmethod print-object ((,class ,class) ,s)
(print-unreadable-object (,class ,s :type t :identity t)
,(destructuring-bind (name value) (car options)
`(format ,s "~a: ~s" ,name (,value ,class)))
,@(loop for (name value) in (cdr options)
collect `(format ,s ", ~a: ~s" ,name (,value ,class)))))))
|