Commit 3df5023f authored by Matthew Steele's avatar Matthew Steele

Lots of changes and improvements, including:

  - Added instrumentation for #. and #S
  - Potentially dangerous heuristics for defvar and defconstant
  - Improved handler for defstruct
  - New unit tests
  - Some cleanup of old code
parent e6bdb949
......@@ -29,13 +29,13 @@ to the base of the system."
;; Used only by with-dependency-tracking.
(defun call-with-dependency-tracking (comp thunk)
;; (if *using-constituents*
(if *current-constituent*
(operating-on-asdf-component-constituent (comp)
;((merge-pathnames (asdf:component-pathname comp)))
(with-groveling-macroexpand-hook
(funcall thunk)))
(funcall thunk)))
(if *current-constituent*
(operating-on-asdf-component-constituent (comp)
;((merge-pathnames (asdf:component-pathname comp)))
(with-groveling-readtable
(with-groveling-macroexpand-hook
(funcall thunk))))
(funcall thunk)))
;; (if *current-dependency-state*
;; (operating-on-component (comp)
;; (let ((file (namestring (merge-pathnames
......
......@@ -10,6 +10,76 @@
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(mapcar #'(lambda (name) `(,name (gensym))) names) ,@body))
(defmacro do-until (condition &body body)
`(do () (,condition) ,@body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Heaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A binary minheap, which can be used as a priority queue.
(flet ((heap-key-function (heap) (car heap))
(heap-vector (heap) (cdr heap))
(parent-index (index) (values (floor (1- index) 2)))
(child-indices (index)
(let ((left (1+ (* 2 index))))
(values left (1+ left))))
(item-key (item) (car item))
(item-obj (item) (cdr item)))
(defun make-heap (&key key)
(unless key
(setf key (lambda (x) x)))
(cons key (make-array 0 :adjustable t :fill-pointer t)))
(defun heap-insert (obj heap)
(let* ((key (funcall (heap-key-function heap) obj))
(item (cons key obj))
(vec (heap-vector heap))
(index (vector-push-extend item vec)))
(do-until (= index 0)
(let ((pindex (parent-index index)))
(if (>= key (item-key (elt vec pindex)))
(return)
(psetf (elt vec index) (elt vec pindex)
(elt vec pindex) (elt vec index)
index pindex)))))
(values))
(defun heap-pop (heap)
(when (heap-empty-p heap)
(return-from heap-pop (values nil nil)))
(let* ((vec (heap-vector heap))
(min-obj (item-obj (elt vec 0)))
(item (vector-pop vec))
(length (fill-pointer vec)))
(when (> length 0)
(let ((key (item-key item))
(index 0))
(loop
(multiple-value-bind (lindex rindex) (child-indices index)
(cond ((>= lindex length)
(return))
((>= rindex length)
(if (<= key (item-key (elt vec lindex)))
(return)
(setf (elt vec index) (elt vec lindex)
index lindex)))
(t (let ((lkey (item-key (elt vec lindex)))
(rkey (item-key (elt vec rindex))))
(cond ((and (<= key lkey)
(<= key rkey))
(return))
((<= lkey rkey)
(setf (elt vec index) (elt vec lindex)
index lindex))
(t
(setf (elt vec index) (elt vec rindex)
index rindex))))))))
(setf (elt vec index) item)))
(values min-obj t)))
(defun heap-count (heap)
(fill-pointer (heap-vector heap)))
(defun heap-empty-p (heap)
(= 0 (heap-count heap))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Hashsets ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hash-set abstraction, since CL doesn't seem to have a set datatype.
(defun make-hashset (&key (test 'eql))
"Create a new hashset with the specified test function."
......@@ -36,7 +106,6 @@
(defmacro do-hashset ((item hashset) &body body)
"Like dolist, but for hashsets."
`(loop-hashset (,item ,hashset)
;;:for ,item :being :the :hash-keys :in ,hashset
:do (progn ,@body)))
(defun hashset-pop (hashset)
"Remove and return an arbitrary item from the hashset."
......@@ -55,7 +124,7 @@
(defclass constituent ()
((parent
:initarg :parent
:initform (error "must supply a parent")
:initform nil
:reader constituent-parent
:documentation "The parent constituent directly containing this one,
or nil if the constituent has no parent.")
......@@ -76,6 +145,13 @@
:accessor constituent-provisions
:documentation "A list of things provided by this constituent.")))
(defmethod initialize-instance :after ((con constituent) &key)
(let ((parent (slot-value con 'parent)))
(when parent
(setf (slot-value con 'index)
(length (slot-value parent 'children)))
(push con (slot-value parent 'children)))))
;; The top-level constituent. This is instantiated by
;; with-constituent-groveling, and will have a nil parent. The only reason to
;; have this as a separate class is so that we can overload
......@@ -111,14 +187,25 @@
:initarg :summary
:initform nil
:reader form-constituent-summary
:documentation "A human-readable sexp summarizing the form.")))
(defmethod initialize-instance :after ((con constituent) &key)
(let ((parent (slot-value con 'parent)))
(when parent
(setf (slot-value con 'index)
(length (slot-value parent 'children)))
(push con (slot-value parent 'children)))))
:documentation "A human-readable string summarizing the form.")))
;; A temporary constituent, typically made with a nil parent. This is used to
;; collect uses and provisions into one place (e.g. for sharpdot
;; instrumentation) before adding them to another constituent using the
;; transfer-constituent function.
(defclass temp-constituent (constituent)
((label
:initarg :label
:initform (error "must supply a label")
:reader temp-constituent-label
:documentation "The label to use as the summary of this constituent.")))
(defun new-temp-constituent ()
"Create a new temp-constituent with an automatically generated label."
(make-instance 'temp-constituent
:label (cons (gensym) (and *current-constituent*
(constituent-designator
*current-constituent*)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -153,6 +240,9 @@
(form-constituent-position con)
(form-constituent-summary con)))
(defmethod constituent-summary ((con temp-constituent))
(temp-constituent-label con))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -189,9 +279,21 @@
(defun constituent-add-provision (provision con)
(hashset-add provision (constituent-provisions con)))
(defun propagate-constituent (con)
(defun propagate-constituent-downward (con)
"Copy all uses and provisions from the constituent to all its descendants,
and do the same for each descendant."
(dolist (child (constituent-children con))
(propagate-constituent child)
(do-hashset (provision (constituent-provisions con))
(constituent-add-provision provision child))
(do-hashset (use (constituent-uses con))
(constituent-add-use use child))
(propagate-constituent-downward child)))
(defun propagate-constituent-upward (con)
"Copy all uses and provisions from the constituent's descendants to it,
and do the same for each descendant."
(dolist (child (constituent-children con))
(propagate-constituent-upward child)
(do-hashset (provision (constituent-provisions child))
(constituent-add-provision provision con))
(do-hashset (use (constituent-uses child))
......@@ -213,17 +315,23 @@
(let ((subtable (make-hash-table :test 'eql)))
(setf (gethash con table) subtable)
(do-hashset (use (constituent-uses con))
(dolist (dep (gethash use provisions))
(unless (or (constituent-descendant-p con dep)
(constituent-descendant-p dep con))
(push use (gethash dep subtable)))))))
;; You don't depend on something you yourself provide (this is
;; important for similar declarations that sometimes appear in
;; multiple files, e.g. defvars).
(unless (hashset-contains-p use (constituent-provisions con))
(dolist (dep (gethash use provisions))
;; You don't depend on something provided by one of your
;; descendants or ancestors.
(unless (or (constituent-descendant-p con dep)
(constituent-descendant-p dep con))
(push use (gethash dep subtable))))))))
table))
(defun get-file-constituents (top)
(let ((file-constituents nil))
(walk-constituents-preorder (con top)
(walk-constituents-postorder (con top)
(typecase con (file-constituent (push con file-constituents))))
(nreverse file-constituents)))
file-constituents))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Graph ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -331,18 +439,96 @@
:when dnode2 :do
(hashset-add dnode1 (dnodes-that-depend-on dnode2))
(hashset-add dnode2 (dnodes-needed-by dnode1))))
(fail-if-not-acyclic graph "during build-merged-graph")
;; Try to merge nodes from the same parent.
(dolist (dnode-set (nreverse dnode-sets))
(do () ((hashset-empty-p dnode-set))
(do-until (hashset-empty-p dnode-set)
(let* ((dnode1 (hashset-pop dnode-set)))
(do-hashset (dnode2 dnode-set)
(when (try-to-merge-dnodes graph dnode1 dnode2)
(hashset-remove dnode2 dnode-set))))))
(fail-if-not-acyclic graph "after build-merged-graph")
graph))
(defun find-a-cycle-if-any (graph)
(let ((expanded (make-hashset :test 'eql))
(stack nil))
(do-hashset (dnode graph)
(push (list dnode) stack))
(do-until (null stack)
(let* ((chain (pop stack))
(head (car chain)))
(hashset-add head expanded)
(do-hashset (next (dnodes-needed-by head))
(when (member next chain :test 'eql)
(return-from find-a-cycle-if-any chain))
(unless (hashset-contains-p next expanded)
(push (cons next chain) stack)))))
nil))
(defun fail-if-not-acyclic (graph message)
(let ((cycle (find-a-cycle-if-any graph)))
(when cycle
(error (format nil "There was a cycle (~A):~%~{ dnode:~%~{ ~S~%~}~}"
message
(loop :for dnode :in cycle :collect
(loop-hashset (con (dnode-constituents dnode))
:collect (constituent-summary con))))))))
(defun topologically-stable-sort-graph (graph parents)
(fail-if-not-acyclic graph "before topologically-stable-sort-graph")
(let* ((sorted-list nil)
(finished (make-hashset :test 'eql)) ;; nodes in sorted-list
(enqueued (make-hashset :test 'eql)) ;; nodes ever to be in heap
(key-table (make-hash-table :test 'eql)) ;; maps dnodes to keys
(heap (make-heap :key (lambda (dnode) (gethash dnode key-table)))))
;; Populate the key-table.
(let ((parents-table (make-hash-table :test 'eql)))
(loop :for parent :in parents :for index :from 1
:do (setf (gethash parent parents-table) index))
(do-hashset (dnode graph)
(let ((index (gethash (dnode-parent dnode) parents-table)))
(assert index)
(setf (gethash dnode key-table)
(- (+ (* 10000 index) ;; this is a gross hack
(loop-hashset (con (dnode-constituents dnode))
:minimize (constituent-index con))))))))
;; Initialize heap to all nodes that no other node depends on -- such
;; nodes can safely come at the _end_ of the list, and thus can be _pushed_
;; onto sorted-list _first_.
(do-hashset (dnode graph)
(when (hashset-empty-p (dnodes-that-depend-on dnode))
(hashset-add dnode enqueued)
(heap-insert dnode heap)))
;; Work until the heap has been emptied.
(do-until (heap-empty-p heap)
;; Pop the next item off the heap, and push it onto sorted-list.
(let ((dnode (heap-pop heap)))
(assert (hashset-contains-p dnode enqueued))
(assert (not (hashset-contains-p dnode finished)))
(hashset-add dnode finished)
(push dnode sorted-list)
;; Now that this node is in sorted-list, examine nodes that depend on
;; this one. Enqueue any such nodes that 1) have never been enqueued,
;; and 2) are not depended on by anything that isn't already in
;; sorted-list. Each node in the graph will thus be enqueued just
;; after the last node that depends on it is enqueued.
(do-hashset (other (dnodes-needed-by dnode))
(when (and (not (hashset-contains-p other enqueued))
(hashset-subset-p (dnodes-that-depend-on other) finished))
(hashset-add other enqueued)
(heap-insert other heap)))))
;; When we're done, every node from the graph should now be in sorted-list,
;; in topological order.
(assert (= (length sorted-list) (hashset-count graph)))
(assert (or (null sorted-list)
(hashset-empty-p (dnodes-needed-by (first sorted-list)))))
sorted-list))
(defun topologically-sort-graph (graph)
"Given an acyclic graph of nodes, return a list of the nodes in topological
order (that is, each node comes before all nodes that depend on it)."
(fail-if-not-acyclic graph "before topologically-sort-graph")
(let ((sorted-list nil)
(finished (make-hashset :test 'eql)) ;; nodes in sorted-list
(enqueued (make-hashset :test 'eql)) ;; nodes ever to be in stack
......@@ -355,7 +541,7 @@
(hashset-add dnode enqueued)
(push dnode stack)))
;; Work until the stack has been emptied.
(do () ((null stack))
(do-until (null stack)
;; Pop the next item off the stack, and push it onto sorted-list.
(let ((dnode (pop stack)))
(assert (hashset-contains-p dnode enqueued))
......
......@@ -5,6 +5,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun wtf (string &rest args)
"WTF stands for When-Trace-Format. When *debug-trace* is non-nil, it will
format some debug info to stdout."
(when *debug-trace*
(apply #'format t (format nil "~&DEBUG: ~A~%" string) args)))
;; Used in a number of places, but not exported.
(eval-when (:compile-toplevel :load-toplevel)
(defun canonical-package-name (package-designator)
......@@ -25,19 +31,25 @@
(define-symbol-macro ,name ,new-name)
,(macroexpand `(,operator ,new-name ,@args) env))))
;; Currently used only by instrumenting-macroexpand-hook.
;; Currently used only by preprocess-form.
(defmacro walk-symbols ((sym form) &body body)
"Visit each symbol in `form' one at a time, bind `sym' to that symbol, and
execute the body."
execute the body. Note that this will not visit non-symbols, such as
numeric literals."
(with-gensyms (visit walk node car cdr)
`(labels ((,visit (,sym) ,@body)
(,walk (,node)
(cond ((symbolp ,node)
(,visit ,node))
((consp ,node)
(loop :for (,car . ,cdr) :on ,node
:do (,walk ,car)
:if (symbolp ,cdr) :do (,visit ,cdr))))))
(loop :for (,car . ,cdr) :on ,node :do
(,walk ,car)
;; We need this next bit in case this is a dotted
;; list with a symbol as the final cdr.
(when (and ,cdr (symbolp ,cdr))
(,visit ,cdr))))
((vectorp ,node)
(loop :for ,car :across ,node :do (,walk ,car))))))
(,walk ,form))))
;; Exists only to be exported.
......@@ -64,8 +76,6 @@
;; Used all over the place.
(defun signal-provider (name form-type)
;; &optional (*current-dependency-state*
;; *current-dependency-state*))
"Signal that symbol `name' of kind `form-type' is being provided by the
current component. For example, (defun foo ...) would signal with `name'
foo and `form-type' defun."
......@@ -75,41 +85,20 @@
(when (and (symbolp name)
(eql (symbol-package name) (find-package :sb-impl)))
(return-from signal-provider (values)))
;; (if *using-constituents*
(when (and *current-constituent*
;; FIXME defvar is problematic; turn it off for now
(not (eql form-type 'defvar)))
(constituent-add-provision (list name form-type)
*current-constituent*))
;; (when (and *current-dependency-state* *current-component*)
;; (with-slots (providers component-counter) *current-dependency-state*
;; (push (list component-counter *current-component*)
;; (gethash (list name form-type) providers)))))
(when *current-constituent*
(constituent-add-provision (list name form-type) *current-constituent*))
(values))
;; Used all over the place.
(defun signal-user (name form-type)
;; &optional (*current-dependency-state*
;; *current-dependency-state*))
"Signal that symbol `name' of kind `form-type' is being used by the
current component. For example, (with-foo ...) might signal with `name'
with-foo and `form-type' defmacro."
;; (if *using-constituents*
(when (and *current-constituent*
;; FIXME defvar is problematic; turn it off for now
(not (eql form-type 'defvar)))
(constituent-add-use (list name form-type)
*current-constituent*))
;; (when (and *current-dependency-state* *current-component*
;; ;; FIXME defvar is problematic; turn it off for non-ASDF for now
;; (not (and *non-asdf-p* (eql form-type 'defvar))))
;; (with-slots (users component-counter) *current-dependency-state*
;; (setf (gethash *current-component* users)
;; (gethash *current-component* users
;; (make-hash-table :test #'equal)))
;; (setf (gethash (list name form-type)
;; (gethash *current-component* users))
;; component-counter))))
(when *current-constituent*
(let ((use (list name form-type)))
;;(wtf "Signal user ~S ->~% ~S" use
;; (constituent-summary *current-constituent*))
(constituent-add-use use *current-constituent*)))
(values))
;; This function is part of the machinery for noticing dependencies due to
......@@ -143,6 +132,49 @@
(signal-user ',name 'define-symbol-macro)
(setf ,expression ,new-value)))
;; Experimental (msteele):
;; (defun signal-variable-use (var-name kind value-name)
;; (signal-user var-name kind)
;; (symbol-value value-name))
;; (defsetf signal-variable-use (var-name kind value-name) (new-value)
;; `(progn
;; (signal-user ,var-name ,kind)
;; (setf (symbol-value ,value-name) ,new-value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Groveling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Usually, with-groveling-readtable and with-groveling-macroexpand-hook are
;; used together, but in fine-grain-instrumented-load they are used separately
;; (the readtable is used when loading the stream, and the macroexpand-hook is
;; applied separatedly on each form).
(defmacro with-groveling-readtable (&body body)
`(let ((*readtable* (make-instrumented-readtable)))
,@body))
(defmacro with-groveling-macroexpand-hook (&body body)
"Turn on the groveling-macroexpand-hook within the body. This macro is
idempotent, so it's safe to nest it."
`(let ((*old-macroexpand-hook* (or *old-macroexpand-hook*
*macroexpand-hook*))
(*macroexpand-hook* #'groveling-macroexpand-hook))
,@body))
;; (defmacro with-groveling-environment ((state verbose debug-object-types
;; base-pathname)
;; &body body)
;; `(let* ((*current-dependency-state* ,state)
;; (*features* (adjoin 'groveling *features*))
;; (*compile-print* ,verbose)
;; (*compile-verbose* ,verbose)
;; (*debug-object-types* ,debug-object-types)
;; (*default-pathname-defaults* ,base-pathname)
;; (*grovel-dir-suffix* (get-universal-time))
;; ;;(*break-on-signals* 'error)
;; (*suspected-variables* (slot-value *current-dependency-state*
;; 'suspected-variables)))
;; ,@body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Instrumentation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Used only by instrument-defun-body.
......@@ -186,6 +218,101 @@
(dolist (,feature (set-difference ,old-features *features*))
(signal-provider ,feature 'removed-feature))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Form Preprocessing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Used only by check-for-transfers.
(defun transfer-constituent (con)
"Add all provisions and uses in the given constituent to the current
constituent."
(wtf "Begin transfer ~S ->~% ~S" (constituent-summary con)
(constituent-summary *current-constituent*))
(do-hashset (use (constituent-uses con))
(wtf " Transfer-USE: ~S" use)
(constituent-add-use use *current-constituent*))
(do-hashset (provision (constituent-provisions con))
(wtf " Transfer-PRO: ~S" provision)
(constituent-add-provision provision *current-constituent*))
(wtf "End transfer ~S ->~% ~S" (constituent-summary con)
(constituent-summary *current-constituent*)))
(defun check-for-transfers (form)
"Return a form similar to the one given, but replace
with-transfer-constituent subforms with their included results, while
transferring the included constituents."
(cond ((consp form)
(if (eql (first form) 'with-transfer-constituent)
;; If the form is ('with-transfer-constituent con result), then
;; transfer the constituent and replace the form with the result.
(progn (transfer-constituent (second form))
(check-for-transfers (third form)))
;; Otherwise, recurse on each member of the form. There are a
;; couple special cases we have to watch out for, which are
;; commented below.
(loop :for (car . cdr) :on form
:if (consp cdr)
;; If the 'with-transfer-constituent appears in the middle of
;; the list, then it's most likely because someone wrote
;; something like (blah blah . #.(stuff)) -- that sort of
;; thing shows up in QPX. Note that the below code is
;; carefully set up so that it will work regardless of
;; whether (third cdr) is a cons or not.
:if (eql (first cdr) 'with-transfer-constituent)
:do (transfer-constituent (second cdr)) :and
:append (cons (check-for-transfers car)
(third cdr)) :into newform :and
:do (return newform)
:else
:collect (check-for-transfers car) :into newform
:end
;; If cdr is not a cons cell, then we're at the end of the
;; list. If cdr is nil, then the :append below is equivalent
;; to just saying :collect (check-for-transfers car), but if
;; cdr is not nil (i.e. this is a dotted list), then it's
;; important that we use the :append way.
:else
:append (cons (check-for-transfers car) cdr) :into newform
:finally (return newform))))
((vectorp form)
;; Note that there are many slightly different sorts of vectors; using
;; (type-of form) instead of just 'vector helps us use the right one.
(map (type-of form) #'check-for-transfers form))
(t form)))
(defun preprocess-form (form)
"Walk the form, signaling any suspected variables or constants, and uses of
symbols from defpackages."
(let ((newform (check-for-transfers form)))
(walk-symbols (sym newform)
;; If the symbol is in a package other than CL or KEYWORD, we should
;; signal that we're using that package.
(let ((package (symbol-package sym)))
(unless (or (null package)
(eql package (find-package :cl))
(eql package (find-package :keyword)))
(signal-user (canonical-package-name package) 'defpackage)))
;; If the symbol is a variable, we should signal that we're using
;; that variable.
;; XXX: heuristic, doesn't catch everything:
(when (hashset-contains-p sym *suspected-variables*)
(signal-user sym 'defvar))
(when (hashset-contains-p sym *suspected-constants*)
(signal-user sym 'defconstant)))
newform))
;; Used by instrumented-sharpdot and fine-grain-instrumented-load.
(defun instrumented-eval (form)
"Like eval, but preprocess the form first, and then eval it with the
groveling-macroexpand-hook in place."
(let ((newform (preprocess-form form))
;; Bind *preprocess-form-p* to nil here so that the
;; groveling-macroexpand-hook won't bother to preprocess any subforms
;; of the form while we're evaluating.
(*preprocess-form-p* nil))
(with-groveling-macroexpand-hook
(eval newform))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Custom Readtable ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(labels ((signal-feature (presentp feature)
(signal-user feature
(if presentp 'feature 'removed-feature)))
......@@ -194,7 +321,8 @@
(case (car x)
((:not not)
(if (cddr x)
(error "too many subexpressions in feature expression: ~S" x)
(error "too many subexpressions in ~
feature expression: ~S" x)
(not (featurep (cadr x)))))
((:and and) (every #'featurep (cdr x)))
((:or or) (some #'featurep (cdr x)))
......@@ -206,7 +334,11 @@
(guts (stream not-p)
(unless (if (let ((*package* (find-package :keyword))
(*read-suppress* nil))
(featurep (read stream t nil t)))
;; We have to use check-for-transfers here, because
;; someone might write, for example, #+#.(some-form).
;; For example, fare-utils does this.
(featurep (check-for-transfers
(read stream t nil t))))
(not not-p)
not-p)
(let ((*read-suppress* t))
......@@ -221,19 +353,62 @@
(defun instrumented-sharpquote (stream subchar numarg)
(declare (ignore subchar numarg))
(when *read-suppress*
(read stream t nil t)
(return-from instrumented-sharpquote nil))
(let ((function (read stream t nil t)))
(when (or (symbolp function)
(and (consp function) (eql 'setf (first function))))
(signal-user function 'defun))
`(function ,function)))
(defun make-instrumented-readtable (&optional (readtable *readtable*))
(setf readtable (copy-readtable readtable))
(set-dispatch-macro-character #\# #\+ #'instrumented-sharp+ readtable)
(set-dispatch-macro-character #\# #\- #'instrumented-sharp- readtable)
(set-dispatch-macro-character #\# #\' #'instrumented-sharpquote readtable)
;; TODO: #.
readtable)
(if (or (symbolp function)
(and (consp function) (eql 'setf (first function))))
(let ((con (new-temp-constituent)))
(let ((*current-constituent* con))
(signal-user function 'defun))
`(with-transfer-constituent ,con (function ,function)))
`(function ,function))))
(defun instrumented-sharpdot (stream subchar numarg)
(declare (ignore subchar numarg))
(when *read-suppress*
(read stream t nil t)
(return-from instrumented-sharpdot nil))
(unless *read-eval*
(error "can't read #. while *READ-EVAL* is NIL"))
(let ((form (read stream t nil t))
(con (new-temp-constituent)))
(wtf "Entering sharpdot constituent: ~S" (constituent-summary con))
(let ((result (let ((*current-constituent* con))
(instrumented-eval form))))
(wtf "Exiting sharpdot constituent: ~S" (constituent-summary con))
`(with-transfer-constituent ,con ,result))))
(defun instrumented-sharp-S (stream subchar numarg)
(declare (ignore subchar numarg))
(when *read-suppress*
(read stream t nil t)
(return-from instrumented-sharp-S nil))
(let ((form (read stream t nil t))
(con (new-temp-constituent)))
(wtf "Entering sharp-S constituent: ~S" (constituent-summary con))
(let ((result (let* ((*current-constituent* con)
(newform (preprocess-form form))
(struct-name (car newform)))
(signal-user struct-name 'defstruct)
;; This is a pretty rough approximation of the behavior of
;; the #S reader macro, but it'll do for now.
(eval (cons (find-symbol (format nil "MAKE-~S" struct-name)
(symbol-package struct-name))
(cdr newform))))))
(wtf "Exiting sharp-S constituent: ~S" (constituent-summary con))
`(with-transfer-constituent ,con ,result))))
(defun make-instrumented-readtable ()
(let ((readtable (copy-readtable)))
(set-dispatch-macro-character #\# #\+ #'instrumented-sharp+ readtable)
(set-dispatch-macro-character #\# #\- #'instrumented-sharp- readtable)
(set-dispatch-macro-character #\# #\' #'instrumented-sharpquote readtable)
(set-dispatch-macro-character #\# #\. #'instrumented-sharpdot readtable)
(set-dispatch-macro-character #\# #\s #'instrumented-sharp-S readtable)
(set-dispatch-macro-character #\# #\S #'instrumented-sharp-S readtable)
readtable))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Macro Expansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -250,6 +425,15 @@
(funcall *old-macroexpand-hook* ,function
,new-macro-body ,env))))
(defmacro does-macroexpand-with-prologue
((function env &key (macroexpand-hook '*old-macroexpand-hook*))
prologue new-macro-body)
`(values t `(progn
,@,prologue
,(let ((*macroexpand-hook* ,macroexpand-hook))
(funcall *old-macroexpand-hook* ,function
,new-macro-body ,env)))))
;; Much like `does-macroexpand', but takes an additional `epilogue' parameter
;; that should be a list of forms. These forms will be inserted after the
;; expanded `new-macro-body' within a progn. The caller must make sure that
......@@ -265,7 +449,7 @@
,new-macro-body ,env))
,@,epilogue)))
;; Used only by instrumenting-macroexpand-hook.
;; Used only by groveling-macroexpand-hook.
(defun handle-macroexpansion (name form function environment)
"Handle macroexpansion of a macro called `name' on `form' with macro function
`function' in `environment'. Either dispatch to the appropriate handler, or
......@@ -281,192 +465,27 @@
(does-not-macroexpand)))))
;; The hook itself.
(defun instrumenting-macroexpand-hook (fun form env)
(defun groveling-macroexpand-hook (fun form env)
"A substitute for `*macroexpand-hook*' that provides the entry into the magic
of asdf-dependency-grovel."
(if (listp form)
;; If the form is a list, we're going to do some magic.
(progn
;; Step 1: Look over the symbols in the original form, in case we need
;; to signal a use of defpackage or defvar.
(walk-symbols (sym form)
;; If the symbol is in a package other than CL or KEYWORD, we should
;; signal that we're using that package.
(let ((package (symbol-package sym)))
(unless (or (null package)
(eql package (find-package :cl))
(eql package (find-package :keyword)))
(signal-user (canonical-package-name package) 'defpackage)))
;; If the symbol is a variable, we should signal that we're using
;; that variable.
;; XXX: heuristic, doesn't catch everything:
;; (when (and (not *using-constituents*)
;; (gethash sym *suspected-variables*))
;; (signal-user sym 'defvar))
)
;; Step 1: Preprocess the form if necessary.
(when *preprocess-form-p*