arnold@bcsaic.UUCP (Arnold Nordsieck) (10/04/89)
I am trying to figure out how to turn on a certain level of type checking for DEFSTRUCT accessor functions. Specifically, when I say: (setf (foo-slot bar) 42) I would like the accessor function to make sure that (foo-p bar) is true. Nothing in the common lisp spec. There appears to be nothing in the explorer manuals or release 4(?) source code. Any ideas???? bill (sorry if five copies of this comes out)
RICE@SUMEX-AIM.STANFORD.EDU (10/06/89)
>> I am trying to figure out how to turn on a certain >> level of type checking for DEFSTRUCT accessor >> functions. Specifically, when I say: >> (setf (foo-slot bar) 42) >> I would like the accessor function to make sure that >> (foo-p bar) is true. Nothing in the common lisp spec. >> There appears to be nothing in the explorer manuals or >> release 4(?) source code. >> Any ideas???? bill (sorry if five copies of this >> comes out) Yes, I have some ideas. There are two answers to this question, depending on whether you are running under Rel 6 or not. a) If you are running a release dating from before Rel 6 then the system does not support this sort of thing. I, however, wrote some code to do this many moons ago. You can load this on top of your system and it will define a macro called defstruct-safe, which is just like defstruct only it generates type check code unless you turn up the optimise speed screw. b) If you had Rel 6 then you might have detected that TI have kindly put in code that will cause in -line type checks to be performed if you declare types and also have safety set high. Thus: (defstruct (fred :Named) a b) (defstruct (jim :Named) a b) ;;; A defstruct of the same ;;; shape but different type. (defun foo (x) (declare (optimize safety 3) (type fred x)) (print (fred-a x))) (foo (make-jim)) -> type check error. Now, for some reason TI has elected not to cause the defsubsts generated by defstruct to be of the form: (defsubst fred-a (fred) (aref (the fred fred) 0)) Perhaps this is because of the bug in DefSubst expansion that I just found whilst trying to cause this behaviour. Even if you generate substs of this form the subst expander does completely the wrong thing and transforms (fred-a x) -> (aref (the x x) 0) which is completely bogus. Anyway, I've found a way around this. You just declare a dummy macro to put in the type check and the subst expander doesn't get confused. Maybe one day I'll even look for the bug. The following is a patch that you should compile/load. From then on any defstructs you compile will generate the correct type information. This will generate type checks if you do something like (proclaim '(optimize (safety 3) (speed 0))). I've been using defstruct type checkling code on the Explorer for years now and couldn't live without it. It still amazes me that neither of the LispM vendors have incorporated this sort of thing. Any system with more than one type of defstruct in it is liable to extremely mysterious bugs without type checking. On a related note: many people are unaware that the default behaviour for defstruct message handlers is to return nil for any unhandled message (!). Thus if you accidentally say (send (make-fred) :bogus) it will merrily return nil instead of giving an error. If you would like it to generate an error then you should do something like the following: (defun (:Property fred named-structure-invoke) (message struct &rest args) (ecase message (:Which-Operations '(:Which-Operations :Print-Self)) (:Print-Self (sys:printing-random-object (struct (first args) :Typep))) ) ) (send (make-fred) :bogus) -> error. Rice. ;------------------------------------------------------------------------------- ;;; Patch code for sys:kernel;structure.lisp follows: ;;; -*- Mode:Common-Lisp; Package:SI; Base:10 -*- ;;; By JPR. (defun the-type-name (name) (intern (string-append "the-" (symbol-name name)) (symbol-package name)) ) ;;; By JPR. (defun make-the-type-macro (name) `(defmacro ,(The-Type-Name name) (x) (list 'the ',name x)) ) (defun make-callable-accessors () (using-defstruct-special-variables) ;; first get the accessor code (let ((code (defstruct-type-description-accessor-code type-description)) (n-args (defstruct-type-description-ref-no-args type-description)) arglist junkpart) ;; come up with the arglist (setf junkpart (if (> n-args 1) (mapcar #'(lambda (x) x (gentemp)) (make-list (1- n-args))) ())) (setf arglist `(,@junkpart ,@(if default-pointer `(&optional (,name ,default-pointer)) `(,name)))) (dolist (slot slot-alist) (let* ((doc (defstruct-slot-description-documentation (rest slot))) (n (defstruct-slot-description-number (rest slot))) (ref (apply code n (append (if but-first ;;; Changes made by JPR here. `((,but-first (,(The-Type-Name name) ,name))) (list `(,(The-Type-Name name) ,name))) junkpart))) (ppss (defstruct-slot-description-ppss (rest slot))) (accessor (if conc-name (create-symbol conc-name (first slot)) (first slot)))) ;; store accessor name in the slot-alist (setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor) ;; Check if it conflicts with a included one: (unless (or (defstruct-slot-description-name-slot-p (rest slot)) ;;don't create accessors for name-slots. (and include (eq accessor (defstruct-slot-description-ref-macro-name (cdr (assoc (car slot) (defstruct-description-slot-alist (get-defstruct-description (car include))) :test #'eq)))))) ;; store accessor name in the slot-alist (setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor) ;;; phd 11/20/85 clears the setf method property (progn (push `(eval-when (compile) (putdecl ',accessor () 'setf-method)) returns) (push `(eval-when (load eval) (remprop ',accessor 'setf-method)) returns)) (if (defstruct-slot-description-read-only (rest slot)) (defstruct-putprop-compile-time accessor #'read-only-slot-setf-method 'setf-method)) (push `(defsubst ,accessor ,arglist ,@(if doc `(,doc) ()) ,function-parent-declaration ,(if (null ppss) (let ((slot-type (defstruct-slot-description-type (rest slot)))) (if (or (emptyp slot-type) (eq slot-type name) ; SUBST-EXPAND would replace the type with the argument name. (and (consp slot-type) (member name slot-type :test #'eq))) ref `(the ,slot-type ,ref))) `(ldb ,ppss ,ref))) returns)))) ;;; This macro definition added by JPR. (push (Make-The-Type-Macro name) returns) returns))