RICE@SUMEX-AIM.STANFORD.EDU (10/06/89)
The following is soe code that will give you defstruct
type checking if you do not have release 6 yet.
Rice.
;-------------------------------------------------------------------------------
;;; -*- Mode:Common-Lisp; Package:SYS; Fonts:(TVFONT); Base:10 -*-
;;; This software developed by:
;;; James Rice
;;; Rich Acuff
;;; at the Stanford University Knowledge Systems Lab in 1986, 1989.
;;;
;;; This work was supported in part by:
;;; DARPA Grant F30602-85-C-0012
;;;----------------------------------------------------------------------
;;; Much of this file is derived from code licensed from Texas Instruments
;;; Inc. Since we'd like them to adopt these changes, we're claiming
;;; no rights to them, however, the following restrictions apply to the
;;; TI code:
;;; Your rights to use and copy Explorer System Software must be obtained
;;; directly by license from Texas Instruments Incorporated. Unauthorized
;;; use is prohibited.
;;; RESTRICTED RIGHTS LEGEND
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED.
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;; MS 2151
;;;
;;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.
;;;----------------------------------------------------------------------
;;; This file contains code from Texas Instruments. It's use must abide by
;;; licensing agreements with those organizations.
;-------------------------------------------------------------------------------
;;; This file contains suitable modifications do Defstruct for TI machines so that they give you
;;; the option of type checking on the arguments to access functions, both during read and write
;;; and to alterant macros.
;;; Whether typechecking is on or not is determined at Defstruct compile time by
;;; the Special variable *TYPECHECKING-ON*. If this is non-nil then
;;; typechecking code is generated, otherwise the generated code is identical in
;;; its semantics to what it is normally, though some of the names of defsubst
;;; arguments might have been changed.
;;; The code herein is a fair bit different between the Symbolics and TI
;;; versions. This is not only because of the differences in their
;;; implementations of Defstruct but, more importantly because of differences
;;; and/or bugs in their implementations of Defsubst or Seft. The differences
;;; and bugs are as follows :-
;;; On the Symbolics define-setf-method is implemented in the CL package. This
;;; is globalised by the compatibility package. The problem here is that even
;;; them it generates Setf methods for CL:Setf and not Global:Setf. For this
;;; reason this file overwrites Global:Setf with Cl:Setf, since CL:Setf should
;;; have a superset of the semantics of Global:Setf anyway.
;;; On Symbolices it is not legal to define a lambda expression within a
;;; Defsubst wih the same name for its arguments as the name of the argument to
;;; the defsubst. This is pretty brain dammaged.
;;; On TI machines it is not possible to do a defsubst of the following form.
;;;
;;; (Defsubst fred (x) (bill x) (alfred 'x))
;;;
;;; since the quoted version of "x" is dequoted. This is a bit of a bind, since
;;; Defstruct always used the name of the type as the name of its argument for
;;; its defsubsts. This makes it impossible to do a defsubst of the following
;;; form.
;;;
;;; (Defsubst fred (x) (if (typep x 'x) (bill x) (ferror "Bletch.")))
;;;
;;; For this reason this implementation transforms its arguments so that they
;;; are not the same as the names of the types.
;-------------------------------------------------------------------------------
(defvar *typechecking-on* t
"When this is non-nil typechecking code will be generated for all defstruct-safe
declarations, which are compiled.
"
)
(Import '*Typechecking-On* 'TICL)
(Export '*Typechecking-On* 'TICL)
(defparameter *typechecking-is-enabled* nil
"When this is non-nil typechecking code will be generated for all defstruct
declarations, which are compiled.
"
)
(defparameter *typechecking-is-locally-disabled* nil
"When this is non-nil typechecking code will not be generated for all defstruct
access functions, which are compiled.
"
)
;-------------------------------------------------------------------------------
(defconstant get-value-from-structure-of-type-error-message
"~*Illegal argument [~A] of type ~A given to Defstruct accessor ~A, where type ~A expected."
)
(defun short-string-for (something)
"Prints something out brielfy to a string."
(let ((*print-array* nil)
(*print-length* 3)
(*print-circle* t)
(*print-level* 2)
)
(declare (special *print-array* *print-length*
*print-circle* *print-level*
)
)
(let ((string (catch-error (format nil "~S" something) nil)))
(if string
string
"Print Error"
)
)
)
)
(defun i-should-optimise-defstructs ()
"True if defstruct accessors should be open coded without type checking."
(declare (special *typechecking-is-locally-disabled* compiler:optimize-switch))
(or *typechecking-is-locally-disabled*
(and (> (compiler:opt-speed compiler:optimize-switch)
(+ 1 (compiler:opt-safety compiler:optimize-switch))
)
)
)
)
(defun is-a-side-effecting-arg (arg)
"Is true is arg has some side effect, like (progn (setq #:g1234 <expr>))."
(and (consp arg)
(or (member (first arg) '(setq setf))
(and (equal 'progn (first arg))
(is-a-side-effecting-arg (first (last arg)))
)
)
)
)
(defmacro get-value-from-structure-of-type
(structure type extractor form name-to-substitute extractor-name)
"This is the general function, which is used in order to do type checking. It
is passed six arguments. These are as follows :-
a) The structure, which is to have a field read or written. It should
be of type Type.
b) The type to which all Structure arguments should conform.
c) A function which can extract the field necessary from the structure.
The body of this is generated by defstruct and is usually an AREF or
such like.
d) A quoted form, which represents the body of the extractor function.
This is used in the Setf method in order to produce the correct
inversion code.
e) The argument name of the structure, which is to be acted on in the Form
argument. This is used in the Setf method so that the actual form for
the expression denoting the structure can be substituted into the
inversion form.
f) The name of the access-function being used. This is used in the
generation of error messages.
This function simply type checks its Structure argument against the Type
argument and if the types match it calls the extractor function in orde to read
the value.
"
(ignore form name-to-substitute)
(if (i-should-optimise-defstructs)
(if (is-a-side-effecting-arg structure)
(if (equal (first structure) 'progn)
(append structure (list (second form)))
(list 'progn structure (second form))
)
(second form)
)
`(if (typep ,structure ,type)
(funcall ,extractor ,structure)
(ferror nil get-value-from-structure-of-type-error-message
;;; Have Structure as ignored arg so that it can be
;;; grabbed in the debugger easily.
,structure (short-string-for ,structure)
(type-of ,structure) ,extractor-name ,type
)
)
)
)
(defmacro without-typechecking (form)
"Causes Form to be compiled without any type checking."
`(compiler-let ((*typechecking-is-locally-disabled* t))
(locally (declare (special *typechecking-is-locally-disabled*)))
,form
)
)
(Import 'Without-Typechecking 'TICL)
(Export 'Without-Typechecking 'TICL)
(defmacro with-typechecking (form)
"Causes Form to be compiled with any type checking enabled."
`(compiler-let ((*typechecking-is-locally-disabled* nil))
(locally (declare (special *typechecking-is-locally-disabled*)))
,form
)
)
(Import 'With-Typechecking 'TICL)
(Export 'With-Typechecking 'TICL)
;-------------------------------------------------------------------------------
(defconstant get-value-from-structure-of-type-setf-error-message
"~*Illegal argument [~A] of type ~A given to Setf of Defstruct accessor ~A, where type ~A expected."
)
(define-setf-method get-value-from-structure-of-type
(structure type extractor form name-to-substitute extractor-name)
;;; This is the Setf method for the function get-value-from-structure-of-type .
;;; It is passed six arguments. These are as follows :-
;;; a) The structure, which is to have a field read or written. It should
;;; be of type Type.
;;; b) The type to which all Structure arguments should conform.
;;; c) A function which can extract the field necessary from the structure.
;;; The body of this is generated by defstruct and is usually an AREF or
;;; such like.
;;; d) A quoted form, which represents the body of the extractor function.
;;; This is used in this Setf method in order to produce the correct
;;; inversion code.
;;; e) The argument name of the structure, which is to be acted on in the Form
;;; argument. This is used in the Setf method so that the actual form for
;;; the expression denoting the structure can be substituted into the
;;; inversion form.
;;; f) The name of the access-function being used. This is used in the
;;; generation of error messages.
;;; This macro conforms to the specification of Define-Setf-Method. The reader
;;; should refer to this for more information. It returns five values. The
;;; most important of these are the fourth and the fifth. The fourth is the
;;; code, which it generates in order to do the assignment to the structure.
;;; The fifth is the expression needed in order to read the structure.
;;; The method for writing works as follws :-
;;; It generates code to do a typecheck on the structure argument and, if this
;;; succeeds do the field assignment, otherwise give an error message. The
;;; assignment is done by means of a Setf. The form, which is to be setfed to
;;; is provided as the Form argument. This means that all that has to be done
;;; is to substitute the structure expression in the form provided for the name
;;; which denotes the form inside the form.
(declare (optimize (safety 0)))
(let ((store-variable (gensym)))
(ignore extractor)
(Values nil
nil
(List store-variable)
(if (i-should-optimise-defstructs)
`(setf ,(subst structure (Second name-to-substitute)
(Second form)
)
,store-variable
)
`(if (typep ,structure ,type)
(setf ,(subst structure (Second name-to-substitute)
(Second form)
)
,store-variable
)
(ferror
nil
get-value-from-structure-of-type-setf-error-message
;;; Have Structure as ignored arg so that it can be
;;; grabbed in the debugger easily.
,structure (short-string-for ,structure)
(type-of ,structure) ,extractor-name ,type
)
)
)
(subst structure (Second name-to-substitute)
(Second form)
)
)
)
)
;-------------------------------------------------------------------------------
(defun change-reference-form
(reference-form type-name structure-name old-structure-name
type-check access-function-name
)
"This function transforms a reference form generated by Defstruct into a form
which will do typechecking if this if needed. It is passed six arguments.
These are as follows :-
a) The reference form generated by Defstruct. This will typically be a
form such as (Aref structure-name 3).
b) The name of the type of the structure being defined.
c) The name of the argument, which will represent the structure in the
access function.
d) The original name of the structure argument, which might have been
transformed in some way because bugs in some implementation of defsubst.
e) A flag, which says whether type checking should be switched on or not.
f) The name of the access-function being used. This is used in the
generation of error messages.
If type checking is not wanted then this function simply returns a transformed
version of the reference form. This has the new structure name swapped for the
old one, since the arguments to the defsubst, into which the value of this
function will go are defined outside it.
If type checking is wanted then an expression denoting a call to
get-value-from-structure-of-type is generated. For an understanding of the
arguments, which are given to get-value-from-structure-of-type, please see the
definition of get-value-from-structure-of-type.
"
(let ((new-reference-form
(subst structure-name old-structure-name reference-form)
)
)
(if type-check
(List 'get-value-from-structure-of-type
structure-name
`(quote ,type-name)
(let ((name (gensym (symbol-name old-structure-name))))
(gensym "G")
`(Function (Lambda (,name)
(declare (unspecial ,name))
,(subst name old-structure-name
reference-form
)
)
)
)
`(quote ,new-reference-form)
`(quote ,structure-name)
`(quote ,access-function-name)
)
new-reference-form
)
)
)
;-------------------------------------------------------------------------------
(defun transform-name (name)
"This function is passed a symbol. It returns a new symbol in the same package
as the original symbol but whose PName is TRANSFORMED-<name>, where <name> is
the PName of the symbol.
"
(if *typechecking-is-enabled*
(if (member name lambda-list-keywords)
name
(if (equal (symbol-package name) pkg-global-package)
(progn (intern (string-append "_" (symbol-name name) "_"))
(Import (string-append "_" (symbol-name name) "_") 'TICL)
(Export (string-append "_" (symbol-name name) "_") 'TICL)
)
(intern (string-append "_" (symbol-name name) "_")
(symbol-package name)
)
)
)
name
)
)
;-------------------------------------------------------------------------------
(defun transform-args (args)
"This function is passed a list of arguments. It returns a similar list but the
first element of the list of arguments is transformed using transform-name.
"
(Cons (transform-name (first args)) (Rest args))
)
;-------------------------------------------------------------------------------
(defun make-defsubst-body (ppss ref name args access-function-name)
"This function is passed five arguments, which are derived inside of the
function defstruct-define-ref-macros. They have the following meanings :-
a) ppss - I don't understand this argument but I need it in the code I have
modified.
b) ref - This is the reference form for the defsubst being generated. It
is typically something like (AREF name 3).
c) name - this is tha nema of the type being defined.
d) args - this is a list of arguments being passed to the defsubst. I have
never known it to have more than one element.
e) access-function-name - the name of the access function used in the
source code. This is used in the generation of error messages.
The original code was as follows :-
(if (null ppss) ref `(ldb ,ppss ,ref))
This function does the same sort of thing only it substitutes a call to
change-reference-form, where ref was before.
"
(Declare (Special *typechecking-is-enabled*))
(if (null ppss)
(change-reference-form ref name
(first (transform-args args))
(first args) *typechecking-is-enabled*
access-function-name
)
`(ldb ,ppss
,(change-reference-form ref name
(first (transform-args args))
(first args) *typechecking-is-enabled*
access-function-name
)
)
)
)
;-------------------------------------------------------------------------------
(defun make-TI-defsubst-body (ppss ref name args access-function-name slot)
"This function is passed five arguments, which are derived inside of the
function defstruct-define-ref-macros. They have the following meanings :-
a) ppss - I don't understand this argument but I need it in the code I have
modified.
b) ref - This is the reference form for the defsubst being generated. It
is typically something like (AREF name 3).
c) name - this is tha nema of the type being defined.
d) args - this is a list of arguments being passed to the defsubst. I have
never known it to have more than one element.
e) access-function-name - the name of the access function used in the
source code. This is used in the generation of error messages.
f) the slot.
This function contains a modified version of an expression, which is present in
"
(Declare (Special *typechecking-is-enabled*))
(let ((new-ref (change-reference-form ref name
(first (transform-args args))
(first args) *typechecking-is-enabled*
access-function-name
)
)
)
(if (null ppss)
(if (emptyp (defstruct-slot-description-type (rest slot)))
new-ref
`(the ,(defstruct-slot-description-type (rest slot)) ,new-ref)
)
`(ldb ,ppss ,new-ref)
)
)
)
;-------------------------------------------------------------------------------
(defun modify-alter-reference-form
(reference-form type-name expr-name access-function-name)
"This function is passed a reference form for a structure, the type name of the
structure, the expression, which denotes the structure and the name of the
access function being used in the source code. The latter is used in the
generation of error messages. It returns a peice of code which is a modified
version of the reference form, which might or might not have type checking
defined in it. Whether type checking is switched on or not is determined by
the :Defstruct-Typechecking-on property of the type name. If this is non-nil
then type checking is swithed on. This property is set when the Defstruct
declaration is made.
"
(change-reference-form reference-form type-name expr-name
expr-name (get type-name :Defstruct-Typechecking-on)
access-function-name
)
)
;-------------------------------------------------------------------------------
;;; The code that follows is the modified versions of the TI
;;; source code needed in order to achieve type checking. The modifications are
;;; made to two functions. These are defstruct-define-ref-macros and
;;; defstruct-expand-alter-macro.
;-------------------------------------------------------------------------------
(defun create-function-parent-declaration ()
(using-defstruct-special-variables)
(setf function-parent-declaration
`(declare (function-parent ,name)
(unspecial ,@(transform-args (list name)))
)
)
)
(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
`((,but-first ,name))
(list 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 ,(transform-args arglist)
,@(if doc
`(,doc)
())
,function-parent-declaration
,(make-TI-defsubst-body ppss ref name arglist accessor slot)
)
returns))))
returns))
;-------------------------------------------------------------------------------
(defmacro defstruct-safe (options &body items)
"Declares a structure with optional type checking of access functions. If the
global *typechecking-on* is T then typechecking will be enabled.
"
`(compiler-let ((*typechecking-is-enabled* *typechecking-on*))
(defstruct ,options ,@items)
)
)
(Import 'Defstruct-Safe 'TICL)
(Export 'Defstruct-Safe 'TICL)
(if (boundp 'zwei:*section-defining-items*)
(pushnew (list 15 "(DEFSTRUCT-SAFE" :Defstruct)
zwei:*section-defining-items*
:test #'Equalp
)
nil
)
;-------------------------------------------------------------------------------
;-------------------------------------------------------------------------------
;-------------------------------------------------------------------------------
;;; This used to be the general named structure message handler.
;-------------------------------------------------------------------------------
;;; James Rice, Stanford KSL, 1986
;;; This file contains a general message handler for named structures, which
;;; will allow them to be printed but which will cause them to give an error if
;;; the structure is sent any message other than :Which-Operations or
;;; :Print-Self. This is distinct from the default behaviour, which simply
;;; returns nil. This message handler is enabled by doing the following
;;; putprop :-
;;; (Putprop 'The-name-of-the-named-structure
;;; 'general-structure-message-handler
;;; 'Named-Structure-Invoke
;;; )
(defun general-structure-message-handler
(message-name thing-to-deal-with &Rest other-arguments)
"This is a general message handler for named structures. It handles two
messages: The first of these is :Which-Operations, which takes takes no
arguments. This message handler replies '(:Which-Operations :Print-Self) to
this. The second message that it responds to is :Print-Self. This message
takes three arguments; the stream to which the object is to be printed, the
indentation depth and a slashification flag. It uses the system's default
named structure printer called si:print-named-structure to do this. If it is
sent a message other than these then an error is caused. this is unlike the
default behaviour, which causes nil to be returned.
"
(if (equal message-name :Print-Self)
(let ((stream (First other-arguments))
(print-depth (Second other-arguments))
(slashify (Third other-arguments))
)
(Ignore slashify print-depth)
(si:print-named-structure (named-structure-p thing-to-deal-with)
thing-to-deal-with
print-depth
stream
(si:which-operations-for-print stream)
)
)
(if (equal message-name :Which-Operations)
'(:Which-Operations :Print-Self)
(ferror "Illegal message sent to structure.")
)
)
)
(Import 'General-Structure-Message-Handler 'TICL)
(Export 'General-Structure-Message-Handler 'TICL)
;-------------------------------------------------------------------------------
;;; The following defines the With-Defstruct-Slots Macro.
;-------------------------------------------------------------------------------
(defun is-in-tree (symbol tree)
"Is true if Symbol occurs in Tree. Special attention is taken to watch for
Setfs so that the symbol is not found in the first component of the thing
being set.
"
(declare (optimize (safety 0)))
(typecase tree
(symbol (eq symbol tree))
(cons (if (and (equal (first tree) 'setf)
(consp (second tree))
)
(or (is-in-tree symbol (rest (second tree)))
(is-in-tree symbol (third tree))
(is-in-tree symbol (cons 'setf (rest (rest (rest tree)))))
)
(or (is-in-tree symbol (first tree))
(is-in-tree symbol (rest tree))
)
)
)
(otherwise nil)
)
)
(defun make-into-string (something)
"Turns symbols, quoted symbols and strings into strings."
(if (and (consp something)
(equal (first something) 'Quote)
(symbolp (second something))
)
(make-into-string (second something))
(if (symbolp something)
(symbol-name something)
(if (stringp something)
(string-upcase something)
(ferror nil "~S cannot be coerced into a string." something)
)
)
)
)
(defun form-full-slot-name (name prefix suffix)
"Takes a name and an optional prefix and suffix and returns a symbol in the
same package as name but with prefix and suffix added.
Thus (form-full-slot-name 'fred nil \"dy\") -> 'freddy
"
(intern (string-append (if prefix (make-into-string prefix) "")
(symbol-name name)
(if suffix (make-into-string suffix) "")
)
(symbol-package name)
)
)
(defun slots-used (slots accessors result body prefix suffix)
"Is given a list of slot names and a body of code. It returns the list of
slot names from the original list which are mentioned in the body.
This list is held in the accumulating arg result. This makes the function
fully self tail recursive.
"
(declare (optimize (safety 0)))
(if (equal nil slots)
result
(let ((name (form-full-slot-name (first slots) prefix suffix)))
(if (is-in-tree name body)
(slots-used (rest slots) (rest accessors)
(cons (list name (first accessors)) result)
body prefix suffix
)
(slots-used (rest slots) (rest accessors)
result body prefix suffix
)
)
)
)
)
(defun make-slot-definitions (slots)
"Is passed a list of slot specs which are lists of the form:
(used-slot-name accessor-name) and returns a list of the form:
((used-1 (accessor-1 structure)) ...)
perhaps with typechecking disabled.
"
(if (equal nil slots)
nil
(let ((slot (first slots)))
(let ((spec
`(,(first slot)
,(if (fboundp 'sys:without-typechecking)
`(sys:without-typechecking
(,(second slot) structure-expression)
)
`(,(second slot) structure-expression)
)
)
)
)
(cons spec (make-slot-definitions (rest slots)))
)
)
)
)
(defmacro with-defstruct-slots
((type expression &Optional (prefix nil) (suffix nil)) &Body body)
" Takes the name of a structure type and an expression whose type is of type
Type. It declares locals for Body, whose names are the same as the
names of the slots of Type. A minimum amount of destructuring and
type checking is performed. To allow nested calls to this macro for
the same structure type prefices and suffices can be added to the names
being defined. These can be either strings or symbols, in which case
their pnames will be used. This all allows you to do destructuring of a
defstruct like :-
(defstruct (a-struct :named (:conc-name nil)) slot-1 slot-2 slot-3)
(defun test (x y)
(with-defstruct-slots (a-struct x)
(with-defstruct-slots (a-struct y 'my-)
(print slot-1)
(print my-slot-2)
(print my-slot-3)
(print slot-2)
(setf (slot-2 x) 5000 (slot-3 x) 100) ; Note the setfs are not corrupted.
(print x)
)
)
)
(test (make-a-struct :slot-1 200 :slot-2 42)
(make-a-struct :slot-1 400 :slot-2 128 :slot-3 :foo)
)
"
(check-type type symbol)
(let ((slots (mapcar #'first
(fourth (get type 'si:Defstruct-Description))
)
)
(accessors (mapcar #'seventh
(fourth (get type 'si:Defstruct-Description))
)
)
)
(let ((slots-used (slots-used slots accessors nil body prefix suffix)))
(if (equal nil slots-used)
`(progn ,expression ,@Body)
`(let ((structure-expression ,expression))
(declare (unspecial structure-expression))
(let ((,(first (first slots-used))
(,(second (first slots-used)) structure-expression)
;; Typechecking will be applied to first element
;; only.
)
,@(make-slot-definitions (rest slots-used))
)
(declare (unspecial ,@(mapcar #'first slots-used)))
,@Body
)
)
)
)
)
)
(Import 'with-defstruct-slots 'TICL)
(Export 'with-defstruct-slots 'TICL)
#+CLOS
(defmacro with-struct-slots
((type expression &Optional (prefix nil) (suffix nil)) &body body)
"Allows read/write access to DEFSTRUCT-defined structures via variable
references. TYPE is a type defined by DEFSTRUCT. EXPRESSION is evaluated
to produce an object of type TYPE. PREFIX, if non-NIL, is prepended to the
names of the created variables, allowing nexted calls without name
collision. SUFFIX is appended similarly. Like CLOS's WITH-ACCESSORS
but used slots don't have to be specified. Example:
(defstruct example a b c)
(setq i1 (make-example :a 1 :b 2 :c 3))
(setq i2 (make-example :a 10 :b 20 :c 30))
(with-struct-slots (example i1 nil "-1")
(with-struct-slots (example i2 'SECOND-)
(print a-1)
(setf a-1 100 second-b 2000)
(print (+ a-1 second-b))
)
)
"
(check-type type symbol)
(let* ((desc (get type 'sys:defstruct-description))
(slots
(mapcar #'first (fourth desc)))
(accessors
(mapcar #'seventh (fourth desc)))
(slots-used (slots-used slots accessors nil body prefix suffix))
)
(if (null slots-used)
`(locally ,expression ,@body)
`(ticlos:with-accessors
,slots-used
,expression
(declare (unspecial ,@(mapcar #'first slots-used)))
,@body
)
)
)
)
(import 'with-struct-slots 'TICL)
(export 'with-struct-slots 'TICL)
(defprop with-struct-slots -1 sys::specially-grind)
(defprop with-struct-slots (1 1) zwei::lisp-indent-offset)