From: Mark Wooding Date: Sun, 30 Aug 2015 09:58:38 +0000 (+0100) Subject: Major effort to plug slot-name leaks. X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/4b8e5c0347115ff30841f1d1e71afe59ecb6c82c Major effort to plug slot-name leaks. 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. --- diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp index 9f1382b..abbf94a 100644 --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -262,6 +262,36 @@ 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%" @@ -276,6 +306,17 @@ (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) diff --git a/src/c-types-class-impl.lisp b/src/c-types-class-impl.lisp index 36e9c50..da16cd2 100644 --- a/src/c-types-class-impl.lisp +++ b/src/c-types-class-impl.lisp @@ -30,8 +30,8 @@ (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. diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index a2c57cd..b9b61bf 100644 --- a/src/c-types-proto.lisp +++ b/src/c-types-proto.lisp @@ -239,11 +239,13 @@ ;;; 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 - type) + %type) +(define-access-wrapper argument-type argument-%type) (export 'commentify-argument-name) (defgeneric commentify-argument-name (name) diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 39ac234..b51870c 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -382,7 +382,7 @@ (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))) diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 950db2b..26782e2 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -208,10 +208,9 @@ (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)) - (setf (slot-value class 'ilayout) - (compute-ilayout class))) + (setf (slot-value class '%ilayout) (compute-ilayout class))) ;;;-------------------------------------------------------------------------- ;;; Vtable layout. diff --git a/src/class-layout-proto.lisp b/src/class-layout-proto.lisp index a4ca263..684fb32 100644 --- a/src/class-layout-proto.lisp +++ b/src/class-layout-proto.lisp @@ -31,7 +31,7 @@ (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)) @@ -65,7 +65,7 @@ (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 @@ -88,7 +88,7 @@ (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 @@ -106,7 +106,7 @@ (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)) @@ -133,7 +133,7 @@ (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. @@ -152,7 +152,7 @@ ;;; 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) @@ -186,7 +186,7 @@ (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 @@ -216,7 +216,7 @@ (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 @@ -237,7 +237,7 @@ (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 @@ -263,7 +263,7 @@ (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 diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index f9d5734..878f813 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -172,7 +172,7 @@ (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)) @@ -216,7 +216,7 @@ (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) @@ -226,7 +226,7 @@ (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 @@ -235,7 +235,7 @@ (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" diff --git a/src/class-output.lisp b/src/class-output.lisp index 8880df5..35269a7 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -165,7 +165,7 @@ 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)) @@ -192,7 +192,7 @@ (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. */~@ @@ -204,7 +204,7 @@ (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) @@ -235,7 +235,7 @@ (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;~%" @@ -245,7 +245,7 @@ (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;~%" @@ -256,7 +256,7 @@ (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;~%" @@ -273,7 +273,7 @@ (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))) @@ -283,7 +283,7 @@ (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) @@ -316,7 +316,7 @@ 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;~%" @@ -327,7 +327,7 @@ (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) @@ -364,7 +364,7 @@ (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~];~%" @@ -373,7 +373,7 @@ (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))))) @@ -381,7 +381,7 @@ (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;~%" @@ -427,7 +427,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -442,7 +442,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -464,7 +464,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -474,7 +474,7 @@ const struct ~A ~A__classobj = {~%" ;;; 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) @@ -492,7 +492,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -508,7 +508,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -522,7 +522,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -535,7 +535,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -551,7 +551,7 @@ const struct ~A ~A__classobj = {~%" (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))) @@ -567,7 +567,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -582,7 +582,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -598,7 +598,7 @@ const struct ~A ~A__classobj = {~%" (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) @@ -651,7 +651,7 @@ const struct ~A ~A__classobj = {~%" (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) diff --git a/src/classes.lisp b/src/classes.lisp index a670b8e..6a48698 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -78,13 +78,13 @@ (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) - (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) @@ -220,8 +220,8 @@ ((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. @@ -259,7 +259,7 @@ ((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 @@ -338,8 +338,8 @@ ((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. @@ -390,8 +390,8 @@ ((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. diff --git a/src/codegen-impl.lisp b/src/codegen-impl.lisp index 3104bcb..170f4a8 100644 --- a/src/codegen-impl.lisp +++ b/src/codegen-impl.lisp @@ -65,21 +65,26 @@ ;; Compound statements. -(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 stream "if (~A)" condition)) + (format stream "if (~A)" #1#)) (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 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 stream "while (~A);" condition)) + (format stream "while (~A);" #1#)) ;; Special varargs hacks. @@ -94,8 +99,10 @@ ;; Expressions. -(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. diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 7c8f65c..535839c 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -175,30 +175,34 @@ ;; 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)) -(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 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 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-c-type type stream name) + (pprint-c-type #1# stream name) (format stream "~:@_~A~:@_~:@_" body))) ;; Formatting utilities. diff --git a/src/method-impl.lisp b/src/method-impl.lisp index c5785a2..4a8249b 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -138,7 +138,7 @@ . (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)))) @@ -159,7 +159,7 @@ (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) @@ -323,7 +323,8 @@ 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)) diff --git a/src/method-proto.lisp b/src/method-proto.lisp index e87745f..b4b788d 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -32,7 +32,7 @@ (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. @@ -80,8 +80,8 @@ (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 @@ -223,8 +223,8 @@ 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. @@ -257,9 +257,13 @@ ;;; 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~:>)" - class (sod-class-nickname chain-head) expr)) + #1# (sod-class-nickname chain-head) #2#)) ;;; Utilities. diff --git a/src/module-proto.lisp b/src/module-proto.lisp index acb1926..9c7fcaf 100644 --- a/src/module-proto.lisp +++ b/src/module-proto.lisp @@ -148,7 +148,8 @@ (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) diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index ca5aaee..1c3c930 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -58,8 +58,8 @@ (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 diff --git a/src/parser/parser-expr-impl.lisp b/src/parser/parser-expr-impl.lisp index e0c681b..5ae4035 100644 --- a/src/parser/parser-expr-impl.lisp +++ b/src/parser/parser-expr-impl.lisp @@ -116,14 +116,14 @@ (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 (function) operator + (with-slots ((function %function)) operator (with-slots (valstack) state (assert (not (or (null valstack) (null (cdr valstack))))) diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp index 7fc2609..ec35445 100644 --- a/src/parser/parser-expr-proto.lisp +++ b/src/parser/parser-expr-proto.lisp @@ -154,7 +154,7 @@ (export 'simple-operator) (defclass simple-operator () - ((function :initarg :function :reader operator-function) + ((%function :initarg :function :reader operator-function) (name :initarg :name :initform "" :reader operator-name)) (:documentation diff --git a/src/parser/parser-impl.lisp b/src/parser/parser-impl.lisp index 0a7d667..352a725 100644 --- a/src/parser/parser-impl.lisp +++ b/src/parser/parser-impl.lisp @@ -129,12 +129,12 @@ (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) - (length :initform (gensym "LEN-") :reader parser-length))) + (%length :initform (gensym "LEN-") :reader parser-length))) (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-")) diff --git a/src/parser/scanner-charbuf-impl.lisp b/src/parser/scanner-charbuf-impl.lisp index 65f6e1e..1919b69 100644 --- a/src/parser/scanner-charbuf-impl.lisp +++ b/src/parser/scanner-charbuf-impl.lisp @@ -65,7 +65,7 @@ (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)) @@ -143,7 +143,7 @@ (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 (loop (acond @@ -254,7 +254,7 @@ ;; 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. diff --git a/src/parser/scanner-impl.lisp b/src/parser/scanner-impl.lisp index 0849648..2abdff4 100644 --- a/src/parser/scanner-impl.lisp +++ b/src/parser/scanner-impl.lisp @@ -62,12 +62,15 @@ (defstruct (string-scanner (:constructor make-string-scanner (string &key (start 0) end - &aux (index start) + &aux (%string string) + (index start) (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)) +(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))) @@ -86,7 +89,7 @@ (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)))) ;;;-------------------------------------------------------------------------- @@ -94,13 +97,14 @@ (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." - (list nil :type list)) + (%list nil :type list)) +(define-access-wrapper list-scanner-list list-scanner-%list) (defmethod scanner-step ((scanner list-scanner)) (pop (list-scanner-list scanner))) diff --git a/src/parser/scanner-proto.lisp b/src/parser/scanner-proto.lisp index d590d77..bd7e160 100644 --- a/src/parser/scanner-proto.lisp +++ b/src/parser/scanner-proto.lisp @@ -176,7 +176,7 @@ (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)) @@ -206,7 +206,10 @@ ;; 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 @@ -220,10 +223,12 @@ (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)) +(define-access-wrapper token-scanner-place-type token-scanner-place-%type + :read-only t) ;; Protocol. diff --git a/src/parser/scanner-token-impl.lisp b/src/parser/scanner-token-impl.lisp index 8ab427a..7629b2d 100644 --- a/src/parser/scanner-token-impl.lisp +++ b/src/parser/scanner-token-impl.lisp @@ -39,11 +39,11 @@ (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)) - (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) @@ -64,7 +64,7 @@ (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 @@ -72,7 +72,7 @@ :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) diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index 0c133d6..e58a928 100644 --- a/src/pset-proto.lisp +++ b/src/pset-proto.lisp @@ -45,7 +45,7 @@ (: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 @@ -57,10 +57,11 @@ (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)) +(define-access-wrapper p-type p-%type) (export 'decode-property) (defgeneric decode-property (raw) diff --git a/src/utilities.lisp b/src/utilities.lisp index be5ce56..099c4ba 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -694,6 +694,26 @@ ,(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. (export 'default-slot)