From: Ken Tilton
Subject: (fix 'defclass) -> DEFKENNY
Date:
Message-ID: <snfpg.38$Dk.15@fe10.lga>
Linebreaks are your problem, as are nose demons. Your hard drive,
however, should be safe:
(defmacro defkenny (class superclasses &rest class-spec)
`(defclass ,class ,superclasses
,@(let (definitargs class-options slots)
(loop with skip
for (spec next) on class-spec
if skip
do (setf skip nil)
else do (etypecase spec
(cons
(cond
((keywordp (car spec))
(assert (find (car spec) '(:documentation
:metaclass)))
(push spec class-options))
((find (cadr spec) '(:initarg :type :initform
:allocation :reader :writer :accessor :documentation))
(push (apply 'defkenny-canonicalize-slot
spec) slots))
(t ;; must be shortform: (slotname initform
&rest slotdef-key-values)
(push (apply 'defkenny-canonicalize-slot
(list* (car spec) :initform (cadr
spec) (cddr spec))) slots))))
(keyword
(setf definitargs (append definitargs (list
spec next)))
(setf skip t))
(symbol (push (list spec :initform nil
:initarg (intern (symbol-name
spec) :keyword)
:accessor spec) slots)))
finally
(return (list* (nreverse slots)
(delete-if 'null
(list* `(:default-initargs ,@definitargs)
(nreverse class-options)))))))))
(defun defkenny-canonicalize-slot (slotname
&key
(type nil type-p)
(initform nil initform-p)
(initarg (intern (symbol-name
slotname) :keyword))
(documentation nil documentation-p)
(unchanged-if nil unchanged-if-p)
(reader slotname reader-p)
(writer `(setf ,slotname) writer-p)
(accessor slotname accessor-p)
(allocation nil allocation-p))
(list* slotname :initarg initarg
(append
(when type-p (list :type type))
(when initform-p (list :initform initform))
(when unchanged-if-p (list :unchanged-if unchanged-if))
(when reader-p (list :reader reader))
(when writer-p (list :writer writer))
(when (or accessor-p
(not (and reader-p writer-p)))
(list :accessor accessor))
(when allocation-p (list :allocation allocation))
(when documentation-p (list :documentation documentation)))))
#+testkenny
(progn
(defclass md-test-super ()())
(defkenny defkenny-test (md-test-super)
(aaa :initform nil :initarg :aaa :accessor aaa)
(aa2 :documentation "hi mom")
bbb
(ccc 42 :allocation :class)
(ddd (c-in nil))
:superx 42 ;; default-initarg
(:documentation "as if!")))
=>
(defclass defkenny-test (md-test-super)
((aaa :initarg :aaa :initform nil :accessor aaa)
(aa2 :initarg :aa2 :accessor aa2 :documentation "hi mom")
(bbb :initform nil :initarg :bbb :accessor bbb)
(ccc :initarg :ccc :initform 42 :accessor ccc :allocation :class)
(ddd :initarg :ddd :initform (c-in nil) :accessor ddd))
(:default-initargs
:superx 42)
(:documentation "as if!"))
You are welcome.
kenny
--
Cells: http://common-lisp.net/project/cells/
"I'll say I'm losing my grip, and it feels terrific."
-- Smiling husband to scowling wife, New Yorker cartoon
From: ········@gmail.com
Subject: Re: (fix 'defclass) -> DEFKENNY
Date:
Message-ID: <1151711554.165990.131790@h44g2000cwa.googlegroups.com>
Ken Tilton wrote:
> Linebreaks are your problem, as are nose demons. Your hard drive,
> however, should be safe:
>
> (defmacro defkenny (class superclasses &rest class-spec)
> `(defclass ,class ,superclasses
> ,@(let (definitargs class-options slots)
> (loop with skip
> for (spec next) on class-spec
> if skip
> do (setf skip nil)
> else do (etypecase spec
> (cons
> (cond
> ((keywordp (car spec))
> (assert (find (car spec) '(:documentation
> :metaclass)))
> (push spec class-options))
> ((find (cadr spec) '(:initarg :type :initform
> :allocation :reader :writer :accessor :documentation))
> (push (apply 'defkenny-canonicalize-slot
> spec) slots))
> (t ;; must be shortform: (slotname initform
> &rest slotdef-key-values)
> (push (apply 'defkenny-canonicalize-slot
> (list* (car spec) :initform (cadr
> spec) (cddr spec))) slots))))
> (keyword
> (setf definitargs (append definitargs (list
> spec next)))
> (setf skip t))
> (symbol (push (list spec :initform nil
> :initarg (intern (symbol-name
> spec) :keyword)
> :accessor spec) slots)))
> finally
> (return (list* (nreverse slots)
> (delete-if 'null
> (list* `(:default-initargs ,@definitargs)
> (nreverse class-options)))))))))
>
> (defun defkenny-canonicalize-slot (slotname
> &key
> (type nil type-p)
> (initform nil initform-p)
> (initarg (intern (symbol-name
> slotname) :keyword))
> (documentation nil documentation-p)
> (unchanged-if nil unchanged-if-p)
> (reader slotname reader-p)
> (writer `(setf ,slotname) writer-p)
> (accessor slotname accessor-p)
> (allocation nil allocation-p))
> (list* slotname :initarg initarg
> (append
> (when type-p (list :type type))
> (when initform-p (list :initform initform))
> (when unchanged-if-p (list :unchanged-if unchanged-if))
> (when reader-p (list :reader reader))
> (when writer-p (list :writer writer))
> (when (or accessor-p
> (not (and reader-p writer-p)))
> (list :accessor accessor))
> (when allocation-p (list :allocation allocation))
> (when documentation-p (list :documentation documentation)))))
>
> #+testkenny
> (progn
> (defclass md-test-super ()())
>
> (defkenny defkenny-test (md-test-super)
> (aaa :initform nil :initarg :aaa :accessor aaa)
> (aa2 :documentation "hi mom")
> bbb
> (ccc 42 :allocation :class)
> (ddd (c-in nil))
> :superx 42 ;; default-initarg
> (:documentation "as if!")))
>
> =>
> (defclass defkenny-test (md-test-super)
> ((aaa :initarg :aaa :initform nil :accessor aaa)
> (aa2 :initarg :aa2 :accessor aa2 :documentation "hi mom")
> (bbb :initform nil :initarg :bbb :accessor bbb)
> (ccc :initarg :ccc :initform 42 :accessor ccc :allocation :class)
> (ddd :initarg :ddd :initform (c-in nil) :accessor ddd))
> (:default-initargs
> :superx 42)
> (:documentation "as if!"))
(defmacro my-defkenny (name superclasses &body class-spec)
(labels ((make-keyword (sym)
(intern (symbol-name sym)
(symbol-package :keyword)))
(ensure-initarg (sd)
(when sd
(if (member :initarg sd)
sd
(let ((n (car sd)))
`(,n :initarg ,(make-keyword n) ,@(cdr sd))))))
(make-accessor (sym)
(intern (concatenate 'string
(string sym)
(string '#:-of))
(symbol-package sym)))
(ensure-accessor (sd)
(when sd
(if (member :accessor sd)
sd
(let ((n (car sd)))
`(,n :accessor ,(make-accessor n) ,@(cdr sd))))))
(expand-lazy-initform (sd)
(if (and (cdr sd)
(not (keywordp (second sd))))
`(,(car sd) :initform ,@(cdr sd))
sd))
(ensure-listp (sd)
(if (listp sd)
sd
(list sd)))
(isolate-class-and-slot-specs (spec)
(flet ((fn (s)
(and (listp s)
(keywordp (car s)))))
(values (remove-if #'fn spec)
(remove-if (complement #'fn) spec))))
(re-roll-naked-default-initargs (spec)
(when spec
(if* (keywordp (car spec))
then (cons (list :default-initargs
(first spec)
(second spec))
(re-roll-naked-default-initargs (cddr spec)))
else (cons (car spec)
(re-roll-naked-default-initargs (cdr spec)))))))
(multiple-value-bind (slot-specs isolated-class-specs)
(isolate-class-and-slot-specs
(re-roll-naked-default-initargs class-spec))
`(defclass ,name ,superclasses
,(map 'list
#'(lambda (s)
(ensure-accessor
(ensure-initarg
(expand-lazy-initform
(ensure-listp s)))))
slot-specs)
,@isolated-class-specs))))
;(defkenny defkenny-test (md-test-super)
; (aaa :initform nil :initarg :aaa :accessor aaa-of)
; (aa2 :documentation "hi mom")
; bbb
; (ccc 42 :allocation :class)
; (ddd (c-in nil))
; :superx 42 ;; default-initarg
; (:documentation "as if!")))
;
; =>
;
; (defclass defkenny-test (md-test-super)
; ((aaa :initarg :aaa :initform nil :accessor aaa-of)
; (aa2 :initarg :aa2 :accessor aa2-of :documentation "hi mom")
; (bbb :initform nil :initarg :bbb :accessor-of bbb)
; (ccc :initarg :ccc :initform 42 :accessor-of ccc :allocation
:class)
; (ddd :initarg :ddd :initform (c-in nil) :accessor-of ddd))
; (:default-initargs
; :superx 42)
; (:documentation "as if!"))
;caveat: generated accessors are SLOT-NAME-OF, not SLOT-NAME
;I'm not sure I really dig having :superx 42 => (:default-initargs
:superx 42)... also, what if I want a slot's initarg to be a keyword?
;nick
>
> You are welcome.
>
> kenny
>
> --
> Cells: http://common-lisp.net/project/cells/
>
> "I'll say I'm losing my grip, and it feels terrific."
> -- Smiling husband to scowling wife, New Yorker cartoonFrom: Maciek Pasternacki
Subject: Re: (fix 'defclass) -> DEFKENNY
Date:
Message-ID: <87k64nrc0f.fsf@japhy.fnord.org>
Little update: allows to use any form defining a class (like UCW's
(DEFCOMPONENT)) and to use any slot-definition arguments (to allow
e.g. UCW's :COMPONENT or AllegroCache's :INDEX args.
(macroexpand-1 '(kenny defcomponent foo (standard-component)
(bar (make-instance 'whatever))
(baz :component 'xyzzy)))
=> (DEFCOMPONENT FOO (STANDARD-COMPONENT)
((BAR :INITARG :BAR :ACCESSOR BAR :INITFORM
(MAKE-INSTANCE 'WHATEVER))
(BAZ :INITARG :BAZ :ACCESSOR BAZ :INITFORM NIL :COMPONENT 'XYZZY))
(:DEFAULT-INITARGS))
On Sweetmorn, Confusion 35, 3172 YOLD, Ken Tilton wrote:
> (defmacro defkenny (class superclasses &rest class-spec)
> `(defclass ,class ,superclasses
(defmacro kenny (class-defining-form class superclasses &rest class-spec)
`(,class-defining-form ,class ,superclasses
[cut]
> ((find (cadr spec) '(:initarg :type :initform
> :allocation :reader :writer :accessor :documentation))
((keywordp (cadr spec))
[cut]
(let ((marker (gensym)))
(defun defkenny-canonicalize-slot (slotname &rest args)
(macrolet ((pull-arg (arg-name default)
`(if (eq marker (getf args ,arg-name marker))
(list ,arg-name ,default)
(prog1
(list ,arg-name (getf args ,arg-name))
(remf args ,arg-name)))))
(list* slotname
(append
(pull-arg :initarg (intern (symbol-name slotname) :keyword))
(when (or (eq marker (getf args :reader marker))
(eq marker (getf args :writer marker)))
(pull-arg :accessor slotname))
(pull-arg :initform nil)
args)))))
--
-><- This signature intentionally left blank. -><-