Permalink
Browse files

Add ensure-generic-function to get rid of sbcl style warnings

  • Loading branch information...
1 parent df1bf85 commit b5cf857704a38d228bb2af78ae1053eff4dfbb12 @Ramarren committed Feb 3, 2009
Showing with 51 additions and 47 deletions.
  1. +48 −44 defmodel.lisp
  2. +3 −3 integrity.lisp
View
@@ -23,41 +23,41 @@ See the Lisp Lesser GNU Public License for more details.
`(progn
(setf (get ',class :cell-types) nil)
(setf (get ',class 'slots-excluded-from-persistence)
- (loop for slotspec in ',slotspecs
- unless (and (getf (cdr slotspec) :ps t)
- (getf (cdr slotspec) :persistable t))
- collect (car slotspec)))
+ (loop for slotspec in ',slotspecs
+ unless (and (getf (cdr slotspec) :ps t)
+ (getf (cdr slotspec) :persistable t))
+ collect (car slotspec)))
(loop for slotspec in ',slotspecs
- do (destructuring-bind
- (slotname &rest slotargs
- &key (cell t)
- &allow-other-keys)
- slotspec
- (declare (ignorable slotargs))
- (when cell
- (setf (md-slot-cell-type ',class slotname) cell))))
+ do (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t)
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when cell
+ (setf (md-slot-cell-type ',class slotname) cell))))
;; define slot macros before class so they can appear in
;; initforms and default-initargs
,@(loop for slotspec in slotspecs
- nconcing (destructuring-bind
- (slotname &rest slotargs
- &key (cell t) (accessor slotname) reader
- &allow-other-keys)
- slotspec
- (declare (ignorable slotargs ))
- (when cell
- (list (let* ((reader-fn (or reader accessor))
- (deriver-fn (intern$ "^" (symbol-name reader-fn))))
- `(eval-when (:compile-toplevel :execute :load-toplevel)
- (unless (macro-function ',deriver-fn)
- (defmacro ,deriver-fn ()
- `(,',reader-fn self)))
- #+sbcl (unless (fboundp ',reader-fn)
- (defgeneric ,reader-fn (slot)))))))))
+ nconcing (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) (accessor slotname) reader
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs ))
+ (when cell
+ (list (let* ((reader-fn (or reader accessor))
+ (deriver-fn (intern$ "^" (symbol-name reader-fn))))
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (unless (macro-function ',deriver-fn)
+ (defmacro ,deriver-fn ()
+ `(,',reader-fn self)))
+ #+sbcl (unless (fboundp ',reader-fn)
+ (defgeneric ,reader-fn (slot)))))))))
- ;
- ; ------- defclass --------------- (^slot-value ,model ',',slotname)
- ;
+ ;
+ ; ------- defclass --------------- (^slot-value ,model ',',slotname)
+ ;
;; create class before prog1 to shut up "can't find type for specializer CLASS in" warnings
;; prog1 kills toplevelness, and eval-when :compile-toplevel part from sbcl defclass is dropped
(defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
@@ -92,14 +92,14 @@ See the Lisp Lesser GNU Public License for more details.
or indirectly from model-object, model-object must be included as a direct super-class in
the defmodel form for ~a" ',class ',class))))
- ;
- ; slot accessors once class is defined...
- ;
+ ;
+ ; slot accessors once class is defined...
+ ;
,@(mapcar (lambda (slotspec)
(destructuring-bind
- (slotname &rest slotargs
- &key (cell t) unchanged-if (accessor slotname) reader writer type
- &allow-other-keys)
+ (slotname &rest slotargs
+ &key (cell t) unchanged-if (accessor slotname) reader writer type
+ &allow-other-keys)
slotspec
(declare (ignorable slotargs))
@@ -109,17 +109,21 @@ the defmodel form for ~a" ',class ',class))))
)
`(progn
,(when writer-fn
- `(defmethod (setf ,writer-fn) (new-value (self ,class))
- (setf (md-slot-value self ',slotname)
- ,(if type
- `(coerce new-value ',type)
- 'new-value))))
+ `(progn
+ (ensure-generic-function '(setf ,writer-fn) :lambda-list '(new-value self))
+ (defmethod (setf ,writer-fn) (new-value (self ,class))
+ (setf (md-slot-value self ',slotname)
+ ,(if type
+ `(coerce new-value ',type)
+ 'new-value)))))
,(when reader-fn
- `(defmethod ,reader-fn ((self ,class))
- (md-slot-value self ',slotname)))
+ `(progn
+ (ensure-generic-function ',reader-fn :lambda-list '(self))
+ (defmethod ,reader-fn ((self ,class))
+ (md-slot-value self ',slotname))))
,(when unchanged-if
`(def-c-unchanged-test (,class ,slotname) ,unchanged-if)))))))
- slotspecs)
+ slotspecs)
(loop for slotspec in ',slotspecs
do (destructuring-bind
(slotname &rest slotargs &key (cell t) owning &allow-other-keys)
View
@@ -18,7 +18,7 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
-(define-constant *ufb-opcodes* '(:tell-dependents
+(define-constant +ufb-opcodes+ '(:tell-dependents
:awaken
:client
:ephemeral-reset
@@ -27,8 +27,8 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro with-integrity ((&optional opcode defer-info debug) &rest body)
(declare (ignorable debug))
(when opcode
- (assert (find opcode *ufb-opcodes*) ()
- "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*))
+ (assert (find opcode +ufb-opcodes+) ()
+ "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode +ufb-opcodes+))
`(call-with-integrity ,opcode ,defer-info
(lambda (opcode defer-info)
(declare (ignorable opcode defer-info))

0 comments on commit b5cf857

Please sign in to comment.