Arrange that all slot names, for structures and CLOS objects, are
internal symbols of the relevant package.
There used to be a number of bad words in slot names, including `class',
`method', `expr', `type', and `condition'. All of these have gone.
I've used two main approaches.
* Renaming the slots with a leading `%'. For structures, this
involves hacking the constructor function to initialize the slot
from a dummy argument with a less unpleasant name, and setting up
trivial reader and writer function wrappers, so there's a new macro
`define-access-wrapper' in utilities.lisp to do this. For CLOS
objects, the accessor functions are named explicitly so that's not
a problem, but there's a lot of work needed to track down direct
slot accesses through `slot-value' and `with-slots'.
* For classes defined through `definst', I've instead named the slots
with gensyms (at read time), because their names are used as part of
automagically defined methods.
I may not have fixed everything: this is a rather invasive change.
24 files changed:
obj))))))
(sb-mop:method-specializers method))))))))))
obj))))))
(sb-mop:method-specializers method))))))))))
+(defun check-slot-names (package)
+ (setf package (find-package package))
+ (let* ((symbols (list-exported-symbols package))
+ (classes (mapcan (lambda (symbol)
+ (when (eq (symbol-package symbol) package)
+ (let ((class (find-class symbol nil)))
+ (and class (list class)))))
+ symbols))
+ (offenders (mapcan
+ (lambda (class)
+ (let* ((slot-names
+ (mapcar #'sb-mop:slot-definition-name
+ (sb-mop:class-direct-slots class)))
+ (exported (remove-if-not
+ (lambda (sym)
+ (or (and (symbol-package sym)
+ (not (eq (symbol-package
+ sym)
+ package)))
+ (member sym symbols)))
+ slot-names)))
+ (and exported
+ (list (cons (class-name class)
+ exported)))))
+ classes))
+ (bad-words (remove-duplicates (mapcan (lambda (list)
+ (copy-list (cdr list)))
+ offenders))))
+ (values offenders bad-words)))
+
(defun report-symbols (paths package)
(setf package (find-package package))
(format t "~A~%Package `~(~A~)'~2%"
(defun report-symbols (paths package)
(setf package (find-package package))
(format t "~A~%Package `~(~A~)'~2%"
(pretty-symbol-name sym package)
(cdr def))))
(terpri)))
(pretty-symbol-name sym package)
(cdr def))))
(terpri)))
+ (multiple-value-bind (alist names) (check-slot-names package)
+ (when names
+ (format t "Leaked slot names: ~{~A~^, ~}~%"
+ (mapcar (lambda (name) (pretty-symbol-name name package))
+ names))
+ (dolist (assoc alist)
+ (format t "~2T~A: ~{~A~^, ~}~%"
+ (pretty-symbol-name (car assoc) package)
+ (mapcar (lambda (name) (pretty-symbol-name name package))
+ (cdr assoc))))
+ (terpri)))
(format t "Classes:~%")
(analyse-classes package)
(terpri)
(format t "Classes:~%")
(analyse-classes package)
(terpri)
(export '(c-class-type c-type-class))
(defclass c-class-type (simple-c-type)
(export '(c-class-type c-type-class))
(defclass c-class-type (simple-c-type)
- ((class :initarg :class :initform nil
- :type (or null sod-class) :accessor c-type-class)
+ ((%class :initarg :class :initform nil
+ :type (or null sod-class) :accessor c-type-class)
(tag :initarg :tag))
(:documentation
"A SOD class, as a C type.
(tag :initarg :tag))
(:documentation
"A SOD class, as a C type.
;;; Function arguments.
(export '(argument argumentp make-argument argument-name argument-type))
;;; Function arguments.
(export '(argument argumentp make-argument argument-name argument-type))
-(defstruct (argument (:constructor make-argument (name type))
+(defstruct (argument (:constructor make-argument (name type
+ &aux (%type type)))
(:predicate argumentp))
"Simple structure representing a function argument."
name
(:predicate argumentp))
"Simple structure representing a function argument."
name
+ %type)
+(define-access-wrapper argument-type argument-%type)
(export 'commentify-argument-name)
(defgeneric commentify-argument-name (name)
(export 'commentify-argument-name)
(defgeneric commentify-argument-name (name)
(setf (values chain-head chain chains) (compute-chains class)))
;; FIXME: make these slots autovivifying.
(setf (values chain-head chain chains) (compute-chains class)))
;; FIXME: make these slots autovivifying.
- (with-slots (ilayout effective-methods vtables) class
+ (with-slots ((ilayout %ilayout) effective-methods vtables) class
(setf ilayout (compute-ilayout class))
(setf effective-methods (compute-effective-methods class))
(setf vtables (compute-vtables class)))
(setf ilayout (compute-ilayout class))
(setf effective-methods (compute-effective-methods class))
(setf vtables (compute-vtables class)))
(sod-class-chains class))))
(defmethod slot-unbound
(sod-class-chains class))))
(defmethod slot-unbound
- (clos-class (class sod-class) (slot-name (eql 'ilayout)))
+ (clos-class (class sod-class) (slot-name (eql '%ilayout)))
(declare (ignore clos-class))
(declare (ignore clos-class))
- (setf (slot-value class 'ilayout)
- (compute-ilayout class)))
+ (setf (slot-value class '%ilayout) (compute-ilayout class)))
;;;--------------------------------------------------------------------------
;;; Vtable layout.
;;;--------------------------------------------------------------------------
;;; Vtable layout.
(export '(effective-slot effective-slot-class
effective-slot-direct-slot effective-slot-initializer))
(defclass effective-slot ()
(export '(effective-slot effective-slot-class
effective-slot-direct-slot effective-slot-initializer))
(defclass effective-slot ()
- ((class :initarg :class :type sod-slot :reader effective-slot-class)
+ ((%class :initarg :class :type sod-slot :reader effective-slot-class)
(slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
(initializer :initarg :initializer :type (or sod-initializer null)
:reader effective-slot-initializer))
(slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
(initializer :initarg :initializer :type (or sod-initializer null)
:reader effective-slot-initializer))
(export '(islots islots-class islots-subclass islots-slots))
(defclass islots ()
(export '(islots islots-class islots-subclass islots-slots))
(defclass islots ()
- ((class :initarg :class :type sod-class :reader islots-class)
+ ((%class :initarg :class :type sod-class :reader islots-class)
(subclass :initarg :subclass :type sod-class :reader islots-subclass)
(slots :initarg :slots :type list :reader islots-slots))
(:documentation
(subclass :initarg :subclass :type sod-class :reader islots-subclass)
(slots :initarg :slots :type list :reader islots-slots))
(:documentation
(export '(vtable-pointer vtable-pointer-class
vtable-pointer-chain-head vtable-pointer-chain-tail))
(defclass vtable-pointer ()
(export '(vtable-pointer vtable-pointer-class
vtable-pointer-chain-head vtable-pointer-chain-tail))
(defclass vtable-pointer ()
- ((class :initarg :class :type sod-class :reader vtable-pointer-class)
+ ((%class :initarg :class :type sod-class :reader vtable-pointer-class)
(chain-head :initarg :chain-head :type sod-class
:reader vtable-pointer-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
(chain-head :initarg :chain-head :type sod-class
:reader vtable-pointer-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
(export '(ichain ichain-class ichain-head ichain-tail ichain-body))
(defclass ichain ()
(export '(ichain ichain-class ichain-head ichain-tail ichain-body))
(defclass ichain ()
- ((class :initarg :class :type sod-class :reader ichain-class)
+ ((%class :initarg :class :type sod-class :reader ichain-class)
(chain-head :initarg :chain-head :type sod-class :reader ichain-head)
(chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
(body :initarg :body :type list :reader ichain-body))
(chain-head :initarg :chain-head :type sod-class :reader ichain-head)
(chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
(body :initarg :body :type list :reader ichain-body))
(export '(ilayout ilayout-class ilayout-ichains))
(defclass ilayout ()
(export '(ilayout ilayout-class ilayout-ichains))
(defclass ilayout ()
- ((class :initarg :class :type sod-class :reader ilayout-class)
+ ((%class :initarg :class :type sod-class :reader ilayout-class)
(ichains :initarg :ichains :type list :reader ilayout-ichains))
(:documentation
"All of the instance layout for a class.
(ichains :initarg :ichains :type list :reader ilayout-ichains))
(:documentation
"All of the instance layout for a class.
;;; vtmsgs
(defclass vtmsgs ()
;;; vtmsgs
(defclass vtmsgs ()
- ((class :initarg :class :type sod-class :reader vtmsgs-class)
+ ((%class :initarg :class :type sod-class :reader vtmsgs-class)
(subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
(chain-head :initarg :chain-head :type sod-class
:reader vtmsgs-chain-head)
(subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
(chain-head :initarg :chain-head :type sod-class
:reader vtmsgs-chain-head)
(export '(class-pointer class-pointer-class class-pointer-chain-head
class-pointer-metaclass class-pointer-meta-chain-head))
(defclass class-pointer ()
(export '(class-pointer class-pointer-class class-pointer-chain-head
class-pointer-metaclass class-pointer-meta-chain-head))
(defclass class-pointer ()
- ((class :initarg :class :type sod-class :reader class-pointer-class)
+ ((%class :initarg :class :type sod-class :reader class-pointer-class)
(chain-head :initarg :chain-head :type sod-class
:reader class-pointer-chain-head)
(metaclass :initarg :metaclass :type sod-class
(chain-head :initarg :chain-head :type sod-class
:reader class-pointer-chain-head)
(metaclass :initarg :metaclass :type sod-class
(export '(base-offset base-offset-class base-offset-chain-head))
(defclass base-offset ()
(export '(base-offset base-offset-class base-offset-chain-head))
(defclass base-offset ()
- ((class :initarg :class :type sod-class :reader base-offset-class)
+ ((%class :initarg :class :type sod-class :reader base-offset-class)
(chain-head :initarg :chain-head :type sod-class
:reader base-offset-chain-head))
(:documentation
(chain-head :initarg :chain-head :type sod-class
:reader base-offset-chain-head))
(:documentation
(export '(chain-offset chain-offset-class
chain-offset-chain-head chain-offset-target-head))
(defclass chain-offset ()
(export '(chain-offset chain-offset-class
chain-offset-chain-head chain-offset-target-head))
(defclass chain-offset ()
- ((class :initarg :class :type sod-class :reader chain-offset-class)
+ ((%class :initarg :class :type sod-class :reader chain-offset-class)
(chain-head :initarg :chain-head :type sod-class
:reader chain-offset-chain-head)
(target-head :initarg :target-head :type sod-class
(chain-head :initarg :chain-head :type sod-class
:reader chain-offset-chain-head)
(target-head :initarg :target-head :type sod-class
(export '(vtable vtable-class vtable-body
vtable-chain-head vtable-chain-tail))
(defclass vtable ()
(export '(vtable vtable-class vtable-body
vtable-chain-head vtable-chain-tail))
(defclass vtable ()
- ((class :initarg :class :type sod-class :reader vtable-class)
+ ((%class :initarg :class :type sod-class :reader vtable-class)
(chain-head :initarg :chain-head :type sod-class
:reader vtable-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
(chain-head :initarg :chain-head :type sod-class
:reader vtable-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
(defmethod shared-initialize :after
((message sod-message) slot-names &key pset)
(declare (ignore slot-names pset))
(defmethod shared-initialize :after
((message sod-message) slot-names &key pset)
(declare (ignore slot-names pset))
- (with-slots (type) message
+ (with-slots ((type %type)) message
(check-message-type message type)))
(defmethod check-message-type ((message sod-message) (type c-function-type))
(check-message-type message type)))
(defmethod check-message-type ((message sod-message) (type c-function-type))
(declare (ignore slot-names pset))
;; Check that the arguments are named if we have a method body.
(declare (ignore slot-names pset))
;; Check that the arguments are named if we have a method body.
- (with-slots (body type) method
+ (with-slots (body (type %type)) method
(unless (or (not body)
(every (lambda (arg)
(or (eq arg :ellipsis)
(unless (or (not body)
(every (lambda (arg)
(or (eq arg :ellipsis)
(error "Abstract declarators not permitted in method definitions")))
;; Check the method type.
(error "Abstract declarators not permitted in method definitions")))
;; Check the method type.
- (with-slots (message type) method
+ (with-slots (message (type %type)) method
(check-method-type method message type)))
(defmethod check-method-type
(check-method-type method message type)))
(defmethod check-method-type
(defmethod check-method-type
((method sod-method) (message sod-message) (type c-function-type))
(defmethod check-method-type
((method sod-method) (message sod-message) (type c-function-type))
- (with-slots ((msgtype type)) message
+ (with-slots ((msgtype %type)) message
(unless (c-type-equal-p (c-type-subtype msgtype)
(c-type-subtype type))
(error "Method return type ~A doesn't match message ~A"
(unless (c-type-equal-p (c-type-subtype msgtype)
(c-type-subtype type))
(error "Method return type ~A doesn't match message ~A"
sequencer))
(defmethod hook-output progn ((class sod-class) reason sequencer)
sequencer))
(defmethod hook-output progn ((class sod-class) reason sequencer)
- (with-slots (ilayout vtables methods effective-methods) class
+ (with-slots ((ilayout %ilayout) vtables methods effective-methods) class
(hook-output ilayout reason sequencer)
(dolist (method methods) (hook-output method reason sequencer))
(dolist (method effective-methods) (hook-output method reason sequencer))
(hook-output ilayout reason sequencer)
(dolist (method methods) (hook-output method reason sequencer))
(dolist (method effective-methods) (hook-output method reason sequencer))
(hook-output item reason sequencer)))
(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)
(hook-output item reason sequencer)))
(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)
- (with-slots (class ichains) ilayout
+ (with-slots ((class %class) ichains) ilayout
(sequence-output (stream sequencer)
((class :ilayout :start)
(format stream "/* Instance layout. */~@
(sequence-output (stream sequencer)
((class :ilayout :start)
(format stream "/* Instance layout. */~@
(hook-output ichain 'ilayout sequencer))))
(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)
(hook-output ichain 'ilayout sequencer))))
(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)
- (with-slots (class chain-head chain-tail) ichain
+ (with-slots ((class %class) chain-head chain-tail) ichain
(when (eq class chain-tail)
(sequence-output (stream sequencer)
:constraint ((class :ichains :start)
(when (eq class chain-tail)
(sequence-output (stream sequencer)
:constraint ((class :ichains :start)
(defmethod hook-output progn ((ichain ichain)
(reason (eql 'ilayout))
sequencer)
(defmethod hook-output progn ((ichain ichain)
(reason (eql 'ilayout))
sequencer)
- (with-slots (class chain-head chain-tail) ichain
+ (with-slots ((class %class) chain-head chain-tail) ichain
(sequence-output (stream sequencer)
((class :ilayout :slots)
(format stream " union ~A ~A;~%"
(sequence-output (stream sequencer)
((class :ilayout :slots)
(format stream " union ~A ~A;~%"
(defmethod hook-output progn ((vtptr vtable-pointer)
(reason (eql :h))
sequencer)
(defmethod hook-output progn ((vtptr vtable-pointer)
(reason (eql :h))
sequencer)
- (with-slots (class chain-head chain-tail) vtptr
+ (with-slots ((class %class) chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
((class :ichain chain-head :slots)
(format stream " const struct ~A *_vt;~%"
(sequence-output (stream sequencer)
((class :ichain chain-head :slots)
(format stream " const struct ~A *_vt;~%"
(hook-output slot reason sequencer)))
(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
(hook-output slot reason sequencer)))
(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
- (with-slots (class subclass slots) islots
+ (with-slots ((class %class) subclass slots) islots
(sequence-output (stream sequencer)
((subclass :ichain (sod-class-chain-head class) :slots)
(format stream " struct ~A ~A;~%"
(sequence-output (stream sequencer)
((subclass :ichain (sod-class-chain-head class) :slots)
(format stream " struct ~A ~A;~%"
(defmethod hook-output progn ((method sod-method)
(reason (eql :h))
sequencer)
(defmethod hook-output progn ((method sod-method)
(reason (eql :h))
sequencer)
- (with-slots (class) method
+ (with-slots ((class %class)) method
(sequence-output (stream sequencer)
((class :methods)
(let ((type (sod-method-function-type method)))
(sequence-output (stream sequencer)
((class :methods)
(let ((type (sod-method-function-type method)))
(format stream ";~%"))))))
(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
(format stream ";~%"))))))
(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
- (with-slots (class chain-head chain-tail) vtable
+ (with-slots ((class %class) chain-head chain-tail) vtable
(when (eq class chain-tail)
(sequence-output (stream sequencer)
:constraint ((class :vtables :start)
(when (eq class chain-tail)
(sequence-output (stream sequencer)
:constraint ((class :vtables :start)
class (sod-class-nickname chain-head))))))
(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
class (sod-class-nickname chain-head))))))
(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
- (with-slots (class subclass chain-head chain-tail) vtmsgs
+ (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
(sequence-output (stream sequencer)
((subclass :vtable chain-head :slots)
(format stream " struct ~A ~A;~%"
(sequence-output (stream sequencer)
((subclass :vtable chain-head :slots)
(format stream " struct ~A ~A;~%"
(reason (eql 'vtmsgs))
sequencer)
(when (vtmsgs-entries vtmsgs)
(reason (eql 'vtmsgs))
sequencer)
(when (vtmsgs-entries vtmsgs)
- (with-slots (class subclass) vtmsgs
+ (with-slots ((class %class) subclass) vtmsgs
(sequence-output (stream sequencer)
:constraint ((subclass :vtmsgs :start)
(subclass :vtmsgs class :start)
(sequence-output (stream sequencer)
:constraint ((subclass :vtmsgs :start)
(subclass :vtmsgs class :start)
(defmethod hook-output progn ((cptr class-pointer)
(reason (eql :h))
sequencer)
(defmethod hook-output progn ((cptr class-pointer)
(reason (eql :h))
sequencer)
- (with-slots (class chain-head metaclass meta-chain-head) cptr
+ (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
(sod-class-nickname meta-chain-head)))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
(sod-class-nickname meta-chain-head)))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) boff
+ (with-slots ((class %class) chain-head) boff
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(write-line " size_t _base;" stream)))))
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(write-line " size_t _base;" stream)))))
(defmethod hook-output progn ((choff chain-offset)
(reason (eql :h))
sequencer)
(defmethod hook-output progn ((choff chain-offset)
(reason (eql :h))
sequencer)
- (with-slots (class chain-head target-head) choff
+ (with-slots ((class %class) chain-head target-head) choff
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(format stream " ptrdiff_t _off_~A;~%"
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(format stream " ptrdiff_t _off_~A;~%"
(defmethod hook-output progn ((method delegating-direct-method)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((method delegating-direct-method)
(reason (eql :c))
sequencer)
- (with-slots (class body) method
+ (with-slots ((class %class) body) method
(unless body
(return-from hook-output))
(sequence-output (stream sequencer)
(unless body
(return-from hook-output))
(sequence-output (stream sequencer)
(defmethod hook-output progn ((method sod-method)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((method sod-method)
(reason (eql :c))
sequencer)
- (with-slots (class body) method
+ (with-slots ((class %class) body) method
(unless body
(return-from hook-output))
(sequence-output (stream sequencer)
(unless body
(return-from hook-output))
(sequence-output (stream sequencer)
(defmethod hook-output progn ((method basic-effective-method)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((method basic-effective-method)
(reason (eql :c))
sequencer)
- (with-slots (class functions) method
+ (with-slots ((class %class) functions) method
(sequence-output (stream sequencer)
((class :effective-methods)
(dolist (func functions)
(sequence-output (stream sequencer)
((class :effective-methods)
(dolist (func functions)
;;; Vtables.
(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)
;;; Vtables.
(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)
- (with-slots (class chain-head chain-tail) vtable
+ (with-slots ((class %class) chain-head chain-tail) vtable
(sequence-output (stream sequencer)
:constraint ((class :vtables :start)
(class :vtable chain-head :start)
(sequence-output (stream sequencer)
:constraint ((class :vtables :start)
(class :vtable chain-head :start)
(defmethod hook-output progn ((cptr class-pointer)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((cptr class-pointer)
(reason (eql :c))
sequencer)
- (with-slots (class chain-head metaclass meta-chain-head) cptr
+ (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :class-pointer metaclass)
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :class-pointer metaclass)
(sod-class-nickname metaclass))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)
(sod-class-nickname metaclass))))))
(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)
- (with-slots (class chain-head) boff
+ (with-slots ((class %class) chain-head) boff
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :base-offset)
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :base-offset)
(defmethod hook-output progn ((choff chain-offset)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((choff chain-offset)
(reason (eql :c))
sequencer)
- (with-slots (class chain-head target-head) choff
+ (with-slots ((class %class) chain-head target-head) choff
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :chain-offset target-head)
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(class :vtable chain-head :chain-offset target-head)
(sod-class-nickname target-head))))))
(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
(sod-class-nickname target-head))))))
(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
- (with-slots (class subclass chain-head) vtmsgs
+ (with-slots ((class %class) subclass chain-head) vtmsgs
(sequence-output (stream sequencer)
:constraint ((subclass :vtable chain-head :start)
(subclass :vtable chain-head :vtmsgs class :start)
(sequence-output (stream sequencer)
:constraint ((subclass :vtable chain-head :start)
(subclass :vtable chain-head :vtmsgs class :start)
(defmethod hook-output progn ((entry method-entry)
(reason (eql :c))
sequencer)
(defmethod hook-output progn ((entry method-entry)
(reason (eql :c))
sequencer)
- (with-slots (method chain-head chain-tail role) entry
+ (with-slots ((method %method) chain-head chain-tail role) entry
(let* ((message (effective-method-message method))
(class (effective-method-class method))
(super (sod-message-class message)))
(let* ((message (effective-method-message method))
(class (effective-method-class method))
(super (sod-message-class message)))
(defmethod hook-output progn ((ichain ichain)
(reason (eql 'class))
sequencer)
(defmethod hook-output progn ((ichain ichain)
(reason (eql 'class))
sequencer)
- (with-slots (class chain-head) ichain
+ (with-slots ((class %class) chain-head) ichain
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object :start)
(*instance-class* :object chain-head :ichain :start)
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object :start)
(*instance-class* :object chain-head :ichain :start)
(defmethod hook-output progn ((islots islots)
(reason (eql 'class))
sequencer)
(defmethod hook-output progn ((islots islots)
(reason (eql 'class))
sequencer)
- (with-slots (class) islots
+ (with-slots ((class %class)) islots
(let ((chain-head (sod-class-chain-head class)))
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object chain-head :ichain :start)
(let ((chain-head (sod-class-chain-head class)))
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object chain-head :ichain :start)
(defmethod hook-output progn ((vtptr vtable-pointer)
(reason (eql 'class))
sequencer)
(defmethod hook-output progn ((vtptr vtable-pointer)
(reason (eql 'class))
sequencer)
- (with-slots (class chain-head chain-tail) vtptr
+ (with-slots ((class %class) chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object chain-head :ichain :start)
(*instance-class* :object chain-head :vtable)
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object chain-head :ichain :start)
(*instance-class* :object chain-head :vtable)
(defmethod hook-output progn ((slot effective-slot)
(reason (eql 'class))
sequencer)
(defmethod hook-output progn ((slot effective-slot)
(reason (eql 'class))
sequencer)
- (with-slots (class (dslot slot)) slot
+ (with-slots ((class %class) (dslot slot)) slot
(let ((instance *instance-class*)
(super (sod-slot-class dslot)))
(sequence-output (stream sequencer)
(let ((instance *instance-class*)
(super (sod-slot-class dslot)))
(sequence-output (stream sequencer)
(class-precedence-list :type list :accessor sod-class-precedence-list)
(class-precedence-list :type list :accessor sod-class-precedence-list)
- (type :type c-class-type :accessor sod-class-type)
+ (%type :type c-class-type :accessor sod-class-type)
(chain-head :type sod-class :accessor sod-class-chain-head)
(chain :type list :accessor sod-class-chain)
(chains :type list :accessor sod-class-chains)
(chain-head :type sod-class :accessor sod-class-chain-head)
(chain :type list :accessor sod-class-chain)
(chains :type list :accessor sod-class-chains)
- (ilayout :type ilayout :accessor sod-class-ilayout)
+ (%ilayout :type ilayout :accessor sod-class-ilayout)
(effective-methods :type list :accessor sod-class-effective-methods)
(vtables :type list :accessor sod-class-vtables)
(effective-methods :type list :accessor sod-class-effective-methods)
(vtables :type list :accessor sod-class-vtables)
((name :initarg :name :type string :reader sod-slot-name)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
((name :initarg :name :type string :reader sod-slot-name)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-slot-class)
- (type :initarg :type :type c-type :reader sod-slot-type))
+ (%class :initarg :class :type sod-class :reader sod-slot-class)
+ (%type :initarg :type :type c-type :reader sod-slot-type))
(:documentation
"Slots are units of information storage in instances.
(:documentation
"Slots are units of information storage in instances.
((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-initializer-class)
+ (%class :initarg :class :type sod-class :reader sod-initializer-class)
(value-kind :initarg :value-kind :type keyword
:reader sod-initializer-value-kind)
(value-form :initarg :value-form :type c-fragment
(value-kind :initarg :value-kind :type keyword
:reader sod-initializer-value-kind)
(value-form :initarg :value-form :type c-fragment
((name :initarg :name :type string :reader sod-message-name)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
((name :initarg :name :type string :reader sod-message-name)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-message-class)
- (type :initarg :type :type c-function-type :reader sod-message-type))
+ (%class :initarg :class :type sod-class :reader sod-message-class)
+ (%type :initarg :type :type c-function-type :reader sod-message-type))
(:documentation
"Messages are the means for stimulating an object to behave.
(:documentation
"Messages are the means for stimulating an object to behave.
((message :initarg :message :type sod-message :reader sod-method-message)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
((message :initarg :message :type sod-message :reader sod-method-message)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-method-class)
- (type :initarg :type :type c-function-type :reader sod-method-type)
+ (%class :initarg :class :type sod-class :reader sod-method-class)
+ (%type :initarg :type :type c-function-type :reader sod-method-type)
(body :initarg :body :type (or c-fragment null) :reader sod-method-body))
(:documentation
"(Direct) methods are units of behaviour.
(body :initarg :body :type (or c-fragment null) :reader sod-method-body))
(:documentation
"(Direct) methods are units of behaviour.
-(definst if (stream :export t) (condition consequent alternative)
+;; HACK: use gensyms for the `condition' slots to avoid leaking the slot
+;; names, since the symbol `condition' actually comes from the `common-lisp'
+;; package. The `definst' machinery will symbolicate the various associated
+;; methods correctly despite this subterfuge.
+
+(definst if (stream :export t) (#1=#:condition consequent alternative)
(format-compound-statement (stream consequent alternative)
(format-compound-statement (stream consequent alternative)
- (format stream "if (~A)" condition))
+ (format stream "if (~A)" #1#))
(when alternative
(format-compound-statement (stream alternative)
(write-string "else" stream))))
(when alternative
(format-compound-statement (stream alternative)
(write-string "else" stream))))
-(definst while (stream :export t) (condition body)
+(definst while (stream :export t) (#1=#:condition body)
(format-compound-statement (stream body)
(format-compound-statement (stream body)
- (format stream "while (~A)" condition)))
+ (format stream "while (~A)" #1#)))
-(definst do-while (stream :export t) (body condition)
+(definst do-while (stream :export t) (body #1=#:condition)
(format-compound-statement (stream body :space)
(write-string "do" stream))
(format-compound-statement (stream body :space)
(write-string "do" stream))
- (format stream "while (~A);" condition))
+ (format stream "while (~A);" #1#))
;; Special varargs hacks.
;; Special varargs hacks.
-(definst call (stream :export t) (func args)
- (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
+;; HACK: use a gensym for the `func' slot to avoid leaking the slot name,
+;; since the symbol `func' is exported from our package.
+(definst call (stream :export t) (#1=#:func args)
+ (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args))
;;;--------------------------------------------------------------------------
;;; Code generator objects.
;;;--------------------------------------------------------------------------
;;; Code generator objects.
;; Important instruction classes.
;; Important instruction classes.
-(definst var (stream :export t) (name type init)
- (pprint-c-type type stream name)
+;; HACK: use a gensym for the `expr' and `type' slots to avoid leaking the
+;; slot names, since the symbol `expr' is exported from our package and
+;; `type' belongs to the `common-lisp' package.
+
+(definst var (stream :export t) (name #1=#:type init)
+ (pprint-c-type #1# stream name)
(when init
(format stream " = ~A" init))
(write-char #\; stream))
(when init
(format stream " = ~A" init))
(write-char #\; stream))
-(definst set (stream :export t) (var expr)
- (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-(definst update (stream :export t) (var op expr)
- (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op expr))
-(definst return (stream :export t) (expr)
- (format stream "return~@[ (~A)~];" expr))
+(definst set (stream :export t) (var #1=#:expr)
+ (format stream "~@<~A = ~@_~2I~A;~:>" var #1#))
+(definst update (stream :export t) (var op #1=#:expr)
+ (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#))
+(definst return (stream :export t) (#1=#:expr)
+ (format stream "return~@[ (~A)~];" #1#))
(definst break (stream :export t) ()
(format stream "break;"))
(definst continue (stream :export t) ()
(format stream "continue;"))
(definst break (stream :export t) ()
(format stream "break;"))
(definst continue (stream :export t) ()
(format stream "continue;"))
-(definst expr (stream :export t) (expr)
- (format stream "~A;" expr))
+(definst expr (stream :export t) (#1=#:expr)
+ (format stream "~A;" #1#))
(definst block (stream :export t) (decls body)
(format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
decls body))
(definst block (stream :export t) (decls body)
(format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
decls body))
-(definst function (stream :export t) (name type body)
+(definst function (stream :export t) (name #1=#:type body)
(pprint-logical-block (stream nil)
(princ "static " stream)
(pprint-logical-block (stream nil)
(princ "static " stream)
- (pprint-c-type type stream name)
+ (pprint-c-type #1# stream name)
(format stream "~:@_~A~:@_~:@_" body)))
;; Formatting utilities.
(format stream "~:@_~A~:@_~:@_" body)))
;; Formatting utilities.
. (c-function-arguments type))))))
(defmethod sod-method-function-name ((method basic-direct-method))
. (c-function-arguments type))))))
(defmethod sod-method-function-name ((method basic-direct-method))
- (with-slots (class role message) method
+ (with-slots ((class %class) role message) method
(format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
(sod-class-nickname (sod-message-class message))
(sod-message-name message))))
(format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
(sod-class-nickname (sod-message-class message))
(sod-message-name message))))
(defmethod check-method-type ((method daemon-direct-method)
(message sod-message)
(type c-function-type))
(defmethod check-method-type ((method daemon-direct-method)
(message sod-message)
(type c-function-type))
- (with-slots ((msgtype type)) message
+ (with-slots ((msgtype %type)) message
(unless (c-type-equal-p (c-type-subtype type) (c-type void))
(error "Method return type ~A must be `void'" (c-type-subtype type)))
(unless (argument-lists-compatible-p (c-function-arguments msgtype)
(unless (c-type-equal-p (c-type-subtype type) (c-type void))
(error "Method return type ~A must be `void'" (c-type-subtype type)))
(unless (argument-lists-compatible-p (c-function-arguments msgtype)
returned by the outermost `around' method -- or, if there are none,
delivered by the BODY -- is finally delivered to the TARGET."
returned by the outermost `around' method -- or, if there are none,
delivered by the BODY -- is finally delivered to the TARGET."
- (with-slots (message class before-methods after-methods around-methods)
+ (with-slots (message (class %class)
+ before-methods after-methods around-methods)
method
(let* ((message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
method
(let* ((message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
(defclass effective-method ()
((message :initarg :message :type sod-message
:reader effective-method-message)
(defclass effective-method ()
((message :initarg :message :type sod-message
:reader effective-method-message)
- (class :initarg :class :type sod-class :reader effective-method-class))
+ (%class :initarg :class :type sod-class :reader effective-method-class))
(:documentation
"The behaviour invoked by sending a message to an instance of a class.
(:documentation
"The behaviour invoked by sending a message to an instance of a class.
(export '(method-entry method-entry-effective-method
method-entry-chain-head method-entry-chain-tail))
(defclass method-entry ()
(export '(method-entry method-entry-effective-method
method-entry-chain-head method-entry-chain-tail))
(defclass method-entry ()
- ((method :initarg :method :type effective-method
- :reader method-entry-effective-method)
+ ((%method :initarg :method :type effective-method
+ :reader method-entry-effective-method)
(chain-head :initarg :chain-head :type sod-class
:reader method-entry-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
(chain-head :initarg :chain-head :type sod-class
:reader method-entry-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
codegen-method codegen-target))
(defclass method-codegen (codegen)
((message :initarg :message :type sod-message :reader codegen-message)
codegen-method codegen-target))
(defclass method-codegen (codegen)
((message :initarg :message :type sod-message :reader codegen-message)
- (class :initarg :class :type sod-class :reader codegen-class)
- (method :initarg :method :type effective-method :reader codegen-method)
+ (%class :initarg :class :type sod-class :reader codegen-class)
+ (%method :initarg :method :type effective-method :reader codegen-method)
(target :initarg :target :reader codegen-target))
(:documentation
"Augments CODEGEN with additional state regarding an effective method.
(target :initarg :target :reader codegen-target))
(:documentation
"Augments CODEGEN with additional state regarding an effective method.
;;; Additional instructions.
;;; Additional instructions.
-(definst convert-to-ilayout (stream :export t) (class chain-head expr)
+;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the
+;; slot names, because `expr' is exported by our package, and `class' is
+;; actually from the `common-lisp' package.
+(definst convert-to-ilayout (stream :export t)
+ (#1=#:class chain-head #2=#:expr)
(format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
(format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
- class (sod-class-nickname chain-head) expr))
+ #1# (sod-class-nickname chain-head) #2#))
(export '(module module-name module-pset module-items module-dependencies))
(defclass module ()
((name :initarg :name :type pathname :reader module-name)
(export '(module module-name module-pset module-items module-dependencies))
(defclass module ()
((name :initarg :name :type pathname :reader module-name)
- (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
+ (%pset :initarg :pset :initform (make-pset)
+ :type pset :reader module-pset)
(items :initarg :items :initform nil :type list :accessor module-items)
(dependencies :initarg :dependencies :initform nil
:type list :accessor module-dependencies)
(items :initarg :items :initform nil :type list :accessor module-items)
(dependencies :initarg :dependencies :initform nil
:type list :accessor module-dependencies)
(export '(enclosing-condition enclosed-condition))
(define-condition enclosing-condition (condition)
(export '(enclosing-condition enclosed-condition))
(define-condition enclosing-condition (condition)
- ((enclosed-condition :initarg :condition :type condition
- :reader enclosed-condition))
+ ((%enclosed-condition :initarg :condition :type condition
+ :reader enclosed-condition))
(:documentation
"A condition which encloses another condition
(:documentation
"A condition which encloses another condition
(defmethod apply-operator
((operator simple-unary-operator) (state expression-parse-state))
(defmethod apply-operator
((operator simple-unary-operator) (state expression-parse-state))
- (with-slots (function) operator
+ (with-slots ((function %function)) operator
(with-slots (valstack) state
(assert (not (null valstack)))
(push (funcall function (pop valstack)) valstack))))
(defmethod apply-operator
((operator simple-binary-operator) (state expression-parse-state))
(with-slots (valstack) state
(assert (not (null valstack)))
(push (funcall function (pop valstack)) valstack))))
(defmethod apply-operator
((operator simple-binary-operator) (state expression-parse-state))
- (with-slots (function) operator
+ (with-slots ((function %function)) operator
(with-slots (valstack) state
(assert (not (or (null valstack)
(null (cdr valstack)))))
(with-slots (valstack) state
(assert (not (or (null valstack)
(null (cdr valstack)))))
(export 'simple-operator)
(defclass simple-operator ()
(export 'simple-operator)
(defclass simple-operator ()
- ((function :initarg :function :reader operator-function)
+ ((%function :initarg :function :reader operator-function)
(name :initarg :name :initform "<unnamed operator>"
:reader operator-name))
(:documentation
(name :initarg :name :initform "<unnamed operator>"
:reader operator-name))
(:documentation
(export 'string-parser)
(defclass string-parser (character-parser-context)
(export 'string-parser)
(defclass string-parser (character-parser-context)
- ((string :initarg :string :reader parser-string)
+ ((%string :initarg :string :reader parser-string)
(index :initarg :index :initform 0 :reader parser-index)
(index :initarg :index :initform 0 :reader parser-index)
- (length :initform (gensym "LEN-") :reader parser-length)))
+ (%length :initform (gensym "LEN-") :reader parser-length)))
(defmethod wrap-parser ((context string-parser) form)
(defmethod wrap-parser ((context string-parser) form)
- (with-slots (string index length) context
+ (with-slots ((string %string) index (length %length)) context
`(let* (,@(unless (symbolp string)
(let ((s string))
(setf string (gensym "STRING-"))
`(let* (,@(unless (symbolp string)
(let ((s string))
(setf string (gensym "STRING-"))
(export 'charbuf-scanner)
(defclass charbuf-scanner (character-scanner)
(export 'charbuf-scanner)
(defclass charbuf-scanner (character-scanner)
- ((stream :initarg :stream :type stream)
+ ((%stream :initarg :stream :type stream)
(buf :initform nil :type (or charbuf (member nil :eof)))
(size :initform 0 :type (integer 0 #.charbuf-size))
(index :initform 0 :type (integer 0 #.charbuf-size))
(buf :initform nil :type (or charbuf (member nil :eof)))
(size :initform 0 :type (integer 0 #.charbuf-size))
(index :initform 0 :type (integer 0 #.charbuf-size))
(if we're currently rewound) or with a new buffer from the stream."))
(defmethod charbuf-scanner-fetch ((scanner charbuf-scanner))
(if we're currently rewound) or with a new buffer from the stream."))
(defmethod charbuf-scanner-fetch ((scanner charbuf-scanner))
- (with-slots (stream buf size index tail captures) scanner
+ (with-slots ((stream %stream) buf size index tail captures) scanner
;; Grab the filename from the underlying stream if we don't have a better
;; guess.
(default-slot (scanner 'filename slot-names)
;; Grab the filename from the underlying stream if we don't have a better
;; guess.
(default-slot (scanner 'filename slot-names)
- (with-slots (stream) scanner
+ (with-slots ((stream %stream)) scanner
(aif (stream-pathname stream) (namestring it) nil)))
;; Get ready with the first character.
(aif (stream-pathname stream) (namestring it) nil)))
;; Get ready with the first character.
(defstruct (string-scanner
(:constructor make-string-scanner
(string &key (start 0) end
(defstruct (string-scanner
(:constructor make-string-scanner
(string &key (start 0) end
+ &aux (%string string)
+ (index start)
(limit (or end (length string))))))
"Scanner structure for a simple string scanner."
(limit (or end (length string))))))
"Scanner structure for a simple string scanner."
- (string "" :type string :read-only t)
+ (%string "" :type string :read-only t)
(index 0 :type (and fixnum unsigned-byte))
(limit nil :type (and fixnum unsigned-byte) :read-only t))
(index 0 :type (and fixnum unsigned-byte))
(limit nil :type (and fixnum unsigned-byte) :read-only t))
+(define-access-wrapper string-scanner-string string-scanner-%string
+ :read-only t)
(defmethod scanner-at-eof-p ((scanner string-scanner))
(>= (string-scanner-index scanner) (string-scanner-limit scanner)))
(defmethod scanner-at-eof-p ((scanner string-scanner))
(>= (string-scanner-index scanner) (string-scanner-limit scanner)))
(defmethod scanner-interval
((scanner string-scanner) place-a &optional place-b)
(defmethod scanner-interval
((scanner string-scanner) place-a &optional place-b)
- (with-slots (string index) scanner
+ (with-slots ((string %string) index) scanner
(subseq string place-a (or place-b index))))
;;;--------------------------------------------------------------------------
(subseq string place-a (or place-b index))))
;;;--------------------------------------------------------------------------
(export 'list-scanner)
(defstruct (list-scanner
(export 'list-scanner)
(defstruct (list-scanner
- (:constructor make-list-scanner (list)))
+ (:constructor make-list-scanner (list &aux (%list list))))
"Simple token scanner for lists.
The list elements are the token semantic values; the token types are the
names of the elements' classes. This is just about adequate for testing
purposes, but is far from ideal for real use."
"Simple token scanner for lists.
The list elements are the token semantic values; the token types are the
names of the elements' classes. This is just about adequate for testing
purposes, but is far from ideal for real use."
+ (%list nil :type list))
+(define-access-wrapper list-scanner-list list-scanner-%list)
(defmethod scanner-step ((scanner list-scanner))
(pop (list-scanner-list scanner)))
(defmethod scanner-step ((scanner list-scanner))
(pop (list-scanner-list scanner)))
(export '(token-scanner token-type token-value))
(defclass token-scanner ()
(export '(token-scanner token-type token-value))
(defclass token-scanner ()
- ((type :reader token-type)
+ ((%type :reader token-type)
(value :reader token-value)
(captures :initform 0 :type fixnum)
(tail :initform nil :type (or token-scanner-place null))
(value :reader token-value)
(captures :initform 0 :type fixnum)
(tail :initform nil :type (or token-scanner-place null))
;; A place marker.
(export '(token-scanner-place token-scanner-place-p))
;; A place marker.
(export '(token-scanner-place token-scanner-place-p))
-(defstruct token-scanner-place
+(defstruct (token-scanner-place
+ (:constructor make-token-scanner-place
+ (&key scanner next type value line column
+ &aux (%type type))))
"A link in the chain of lookahead tokens; capturable as a place.
If the scanner's place is captured, it starts to maintain a list of
"A link in the chain of lookahead tokens; capturable as a place.
If the scanner's place is captured, it starts to maintain a list of
(scanner nil :type token-scanner :read-only t)
(next nil :type (or token-scanner-place null))
(scanner nil :type token-scanner :read-only t)
(next nil :type (or token-scanner-place null))
- (type nil :read-only t)
+ (%type nil :read-only t)
(value nil :read-only t)
(line 1 :type (or fixnum null) :read-only t)
(column 0 :type (or fixnum null) :read-only t))
(value nil :read-only t)
(line 1 :type (or fixnum null) :read-only t)
(column 0 :type (or fixnum null) :read-only t))
+(define-access-wrapper token-scanner-place-type token-scanner-place-%type
+ :read-only t)
(scanner-step scanner))
(defmethod scanner-at-eof-p ((scanner token-scanner))
(scanner-step scanner))
(defmethod scanner-at-eof-p ((scanner token-scanner))
- (with-slots (type) scanner
+ (with-slots ((type %type)) scanner
(eq type :eof)))
(defmethod scanner-step ((scanner token-scanner))
(eq type :eof)))
(defmethod scanner-step ((scanner token-scanner))
- (with-slots (type value tail captures line column) scanner
+ (with-slots ((type %type) value tail captures line column) scanner
(acond ((and tail (token-scanner-place-next tail))
(setf type (token-scanner-place-type it)
value (token-scanner-place-value it)
(acond ((and tail (token-scanner-place-next tail))
(setf type (token-scanner-place-type it)
value (token-scanner-place-value it)
(setf tail nil)))))))
(defmethod scanner-capture-place ((scanner token-scanner))
(setf tail nil)))))))
(defmethod scanner-capture-place ((scanner token-scanner))
- (with-slots (type value captures tail line column) scanner
+ (with-slots ((type %type) value captures tail line column) scanner
(incf captures)
(or tail
(setf tail (make-token-scanner-place :scanner scanner
(incf captures)
(or tail
(setf tail (make-token-scanner-place :scanner scanner
:line line :column column)))))
(defmethod scanner-restore-place ((scanner token-scanner) place)
:line line :column column)))))
(defmethod scanner-restore-place ((scanner token-scanner) place)
- (with-slots (type value tail line column) scanner
+ (with-slots ((type %type) value tail line column) scanner
(setf type (token-scanner-place-type place)
value (token-scanner-place-value place)
line (token-scanner-place-line place)
(setf type (token-scanner-place-type place)
value (token-scanner-place-value place)
line (token-scanner-place-line place)
(:constructor %make-property
(name value
&key type location seenp
(:constructor %make-property
(name value
&key type location seenp
- &aux (key (property-key name)))))
+ &aux (key (property-key name)) (%type type))))
"A simple structure for holding a property in a property set.
The main useful feature is the ability to tick off properties which have
"A simple structure for holding a property in a property set.
The main useful feature is the ability to tick off properties which have
(name nil :type (or string symbol))
(value nil :type t)
(name nil :type (or string symbol))
(value nil :type t)
- (type nil :type symbol)
+ (%type nil :type symbol)
(location (file-location nil) :type file-location)
(key nil :type symbol)
(seenp nil :type boolean))
(location (file-location nil) :type file-location)
(key nil :type symbol)
(seenp nil :type boolean))
+(define-access-wrapper p-type p-%type)
(export 'decode-property)
(defgeneric decode-property (raw)
(export 'decode-property)
(defgeneric decode-property (raw)
,(loopguts t t end)
,(loopguts indexvar t nil))))))))))
,(loopguts t t end)
,(loopguts indexvar t nil))))))))))
+;;;--------------------------------------------------------------------------
+;;; Structure accessor hacks.
+
+(export 'define-access-wrapper)
+(defmacro define-access-wrapper (from to &key read-only)
+ "Make (FROM THING) work like (TO THING).
+
+ If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like
+ (setf (TO THING) VALUE).
+
+ This is mostly useful for structure slot accessors where the slot has to
+ be given an unpleasant name to avoid it being an external symbol."
+ `(progn
+ (declaim (inline ,from ,@(and (not read-only) `((setf ,from)))))
+ (defun ,from (object)
+ (,to object))
+ ,@(and (not read-only)
+ `((defun (setf ,from) (value object)
+ (setf (,to object) value))))))
+
;;;--------------------------------------------------------------------------
;;; CLOS hacking.
;;;--------------------------------------------------------------------------
;;; CLOS hacking.
~mdw / sod / commitdiff