Florian Dietz
unread,Jun 18, 2013, 8:48:00 AM6/18/13You do not have permission to delete messages in this group
Either email addresses are anonymous for this group or you need the view member email addresses permission to view the original message
to
I am trying to write a macro setf* that works like setf but will call a function to check if the necessary locks are acquired if the value to set has a certain form, namely (setf* (<accessor> <object>) <value>) and the accessor has a certain attribute. If this work, I can use the function (check-locking <sym>) when setting the accessor of a slot of a class and automatically make the program check for race conditions. Unfortunately, I can't get it to work.
Can you find the bug in the macro setf*?
Alternatively, can you tell me if such a feature already exists elsewhere, so that I can use that instead?
(defmacro setf* (&rest rst)
"applies setf* and signals a warning if *check-lock-management-detailed* is true
and the symbol has an original version.
Note that this does not detect race conditions on objects that are not slots"
(if (and *check-lock-management* *check-lock-management-detailed*)
;; if body has the form ((x y) z)
(if (and (typep (car rst) 'list)
(eql (type-of (caar rst)) 'symbol)
(= (length (car rst)) 2))
(let ((sym-o (caar rst))
(sym (gensym))
(sym-alt (gensym))
(obj-o (cadar rst))
(obj (gensym))
(obj-r (gensym))
(val-o (cadr rst))
(val (gensym))
(val-r (gensym)))
`(let* (,sym ,sym-alt ,obj ,obj-r ,val ,val-r)
;; evaluate the object to access right here, so it only happens once
(setq ,obj ,obj-o)
;; same with the assignment value
(setq ,val ,val-o)
;; add another layer of symbols
(setq ,sym ',sym-o)
(setq ,obj-r ',obj)
(setq ,val-r ',val)
;; this check must occur at runtime because the attribute may not be set yet at compile time
(setq ,sym-alt (get ,sym *actual-symbol-attribute*))
(if ,sym-alt
;; use the actual accessor
(progn
(verify-lock-on-object-exists ,obj (string+ "setting: " (symbol-name ,sym)))
(eval (list 'setf (list ,sym-alt ,obj-r) ,val-r))
)
;; use the original accessor
;;; reconstruct instead of simple (setf* ,@rst) because obj should only be evaluated once
(setf (,sym-o ,obj) ,val)
)))
`(setf ,@rst)
)
`(setf ,@rst)
))
(defun check-locking (old-sym)
"applies check-locking to an accessor symbol of a class.
Note that when this is used on a slot that exists for several classes, it must be used on all of them"
(if (and *check-lock-management* *check-lock-management-detailed*)
(let (old-name new-name new-sym)
(setq old-name (symbol-name old-sym))
(setq new-name (string+ "NEW-SYMBOL-OF-ACCESSOR-SYMBOL-" old-name))
(setq new-sym (intern new-name))
(setf (get old-sym *actual-symbol-attribute*) new-sym)
;; set the old-sym to verify the existence of the lock, then return the value
;;; this gives a warning about how ,new-sym isn't a function (because it isn't, yet)
;;; this warning is suppressed
(let ((*error-output* (make-broadcast-stream)))
(eval `(defun ,old-sym (obj)
(verify-lock-on-object-exists obj (string+ "reading: " ,old-name))
(,new-sym obj)
)))
new-sym
)
old-sym
))