Index: /branches/gz-working/compiler/PPC/ppc2.lisp =================================================================== --- /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8462) +++ /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8463) @@ -170,5 +170,4 @@ (defvar *ppc2-record-symbols* nil) (defvar *ppc2-recorded-symbols* nil) -(defvar *ppc2-emitted-source-notes* ()) (defvar *ppc2-result-reg* ppc::arg_z) @@ -465,4 +464,6 @@ (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit)))) (let* ((function-debugging-info (afunc-lfun-info afunc))) (when (or function-debugging-info lambda-form *ppc2-record-symbols*) @@ -2147,4 +2148,5 @@ (let ((note (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))) (when note + (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) (with-ppc-local-vinsn-macros (seg) (! vpush-register ppc::arg_x) @@ -2155,6 +2157,7 @@ (defppc2 ppc2-with-source-note with-source-note (seg vreg xfer note form &aux val) (when *record-pc-mapping* - (append-dll-node (setq (setf (source-note-start note) (make-vinsn-label nil)) seg))) + (append-dll-node (setf (source-note-start-pc note) (make-vinsn-label nil)) seg)) (when *compile-code-coverage* + (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) (with-ppc-local-vinsn-macros (seg) (ppc2-store-immediate seg note ($ ppc::arg_x)) @@ -9109,4 +9112,14 @@ (list nil (list arg)))))))) +(defun show-function-constants (f) + (cond ((typep f 'function) + (do* ((i 0 j) + (n (uvsize f)) + (j 1 (1+ j))) + ((= j n)) + (format t "~&~d: ~s" i (uvref f j)))) + (t (report-bad-arg f 'function)))) + + ;------ Index: /branches/gz-working/compiler/lambda-list.lisp =================================================================== --- /branches/gz-working/compiler/lambda-list.lisp (revision 8462) +++ /branches/gz-working/compiler/lambda-list.lisp (revision 8463) @@ -25,6 +25,6 @@ (getf (%lfun-info fn) 'function-symbol-map)) -(defun function-source-text (fn) - (get (%lfun-info fn) 'text)) +(defun function-source-note (fn) + (get (%lfun-info (require-type fn 'function) 'function-source-note))) (defun %lfun-info-index (fn) Index: /branches/gz-working/compiler/nx.lisp =================================================================== --- /branches/gz-working/compiler/nx.lisp (revision 8462) +++ /branches/gz-working/compiler/nx.lisp (revision 8463) @@ -156,5 +156,5 @@ `(gethash ,form *nx-source-note-map*)) -(defun nx-find-or-make-source-note (form parent) +(defun nx-ensure-source-note (form parent) ;; Here's a fun code coverage issue: What if the same source form gets used multiple ;; times. e.g. (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))). @@ -175,4 +175,5 @@ (loop for aa on args by #'cddr always (keywordp (car aa)))) (apply #'compile-named-function-1 def args) + #-BOOTSTRAPPED (destructuring-bind (&optional name env keep-lambda keep-symbols policy load-time-eval-token target) args (compile-named-function-1 def @@ -185,5 +186,5 @@ :target target)))) -(defun compile-named-function-1 (def &key name env source keep-lambda keep-symbols policy load-time-eval-token target source-locations) +(defun compile-named-function-1 (def &key name env source-note keep-lambda keep-symbols policy load-time-eval-token target source-locations) (when (and name *nx-discard-xref-info-hook*) (funcall *nx-discard-xref-info-hook* name)) @@ -203,5 +204,5 @@ (or policy *default-compiler-policy*) *load-time-eval-token* - source))) + source-note))) (if (afunc-lfun afunc) afunc Index: /branches/gz-working/compiler/nx0.lisp =================================================================== --- /branches/gz-working/compiler/nx0.lisp (revision 8462) +++ /branches/gz-working/compiler/nx0.lisp (revision 8463) @@ -78,5 +78,5 @@ (defvar *nx-operators* ()) (defvar *nx-warnings* nil) -(defvar *nx-ccrec* nil) +(defvar *nx-current-source-note* nil) (defvar *nx1-compiler-special-forms* nil "Real special forms") @@ -1253,5 +1253,5 @@ (policy *default-compiler-policy*) load-time-eval-token - source) + source-note) (if q (setf (afunc-parent p) q)) @@ -1286,5 +1286,5 @@ (parse-body (%cddr lambda-form) *nx-lexical-environment* t) (setf (afunc-lambdaform p) lambda-form) - (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls source)) + (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls source-note)) (nx1-transitively-punt-bindings *nx-punted-vars*) (setf (afunc-blocks p) *nx-blocks*) @@ -1307,24 +1307,14 @@ (consp (setq form (%cdr form))) (eq (caar form) '&method))) - - - -(defun make-afunc-source-note (afunc source-form) - ;; Makes a source note and stores it in the lfun-info. - (let* ((source-note (nx-find-or-make-source-note source-form nil)) - (lambda (afunc-lambdaform afunc)) - (lambda-note (nx-find-or-make-source-note lambda source-note))) - (setf (afunc-lfun-info afunc) - (list* 'function-source-note lambda-note (afunc-lfun-info afunc))) - lambda-note)) - -(defun nx1-lambda (ll body decls &optional source-form &aux (l ll) methvar) + + +(defun nx1-lambda (ll body decls &optional source-note &aux (l ll) methvar) + (when source-note + (setf (afunc-lfun-info *nx-current-function*) + (list* 'function-source-note source-note (afunc-lfun-info *nx-current-function*)))) (let* ((old-env *nx-lexical-environment*) (*nx-bound-vars* *nx-bound-vars*) - ;; Make a toplevel source note even if not recording pc mapping or code coverage, - ;; just to store it for lfun source location info. - (source-note (when *nx-source-note-map* - (make-afunc-source-note *nx-current-function* source-form))) - (*nx-ccrec* (and (or *compile-code-coverage* *record-pc-mapping*) source-note))) + (*nx-current-source-note* (and (or *compile-code-coverage* *record-pc-mapping*) source-note))) + (with-nx-declarations (pending) (let* ((*nx-parsing-lambda-decls* t)) @@ -1581,9 +1571,11 @@ (defun nx1-transformed-form (form env &optional original) - (if *nx-ccrec* + (if (and (consp form) *nx-current-source-note*) (let* ((original (or original form)) - (*nx-ccrec* (nx-find-or-make-source-note original *nx-ccrec*))) + (*nx-current-source-note* (nx-ensure-source-note original *nx-current-source-note*))) + (unless *nx-current-source-note* + (compiler-bug "No source note for ~s -> ~s" original form)) (make-acode (%nx1-operator with-source-note) - *nx-ccrec* + *nx-current-source-note* (nx1-transformed-form-aux form env))) (nx1-transformed-form-aux form env))) Index: /branches/gz-working/compiler/nxenv.lisp =================================================================== --- /branches/gz-working/compiler/nxenv.lisp (revision 8462) +++ /branches/gz-working/compiler/nxenv.lisp (revision 8463) @@ -474,4 +474,5 @@ (defconstant $fbitruntimedef 8) (defconstant $fbitnonnullenv 9) +(defconstant $fbitccoverage 10) (defconstant $eaclosedbit 24) Index: /branches/gz-working/level-0/l0-init.lisp =================================================================== --- /branches/gz-working/level-0/l0-init.lisp (revision 8462) +++ /branches/gz-working/level-0/l0-init.lisp (revision 8463) @@ -132,4 +132,6 @@ (defparameter *loading-file-source-file* nil) +(defvar *code-covered-functions* nil "All lfuns instrumented for code coverage") + (defvar *nx-speed* 1) (defvar *nx-space* 1) Index: /branches/gz-working/level-1/l1-init.lisp =================================================================== --- /branches/gz-working/level-1/l1-init.lisp (revision 8462) +++ /branches/gz-working/level-1/l1-init.lisp (revision 8463) @@ -260,4 +260,5 @@ (defparameter *save-definitions* nil) (defparameter *save-local-symbols* t) +(defparameter *save-source-locations* nil) (defvar *modules* nil Index: /branches/gz-working/level-1/l1-reader.lisp =================================================================== --- /branches/gz-working/level-1/l1-reader.lisp (revision 8462) +++ /branches/gz-working/level-1/l1-reader.lisp (revision 8463) @@ -2980,5 +2980,5 @@ (defstruct (source-note (:constructor %make-source-note)) - ;; Code coverage state. This MUST be the first slot - see nx**2-code-coverage. + ;; Code coverage state. This MUST be the first slot - see nx2-code-coverage. code-coverage ;; The actual form @@ -3000,4 +3000,14 @@ subform-notes) +(defmethod make-load-form ((note source-note) &optional env) + (make-load-form-saving-slots note :environment env)) + +(defmethod print-object ((note source-note) stream) + (declare (ignore stream)) + (if *print-circle* + (call-next-method) + (let ((*print-circle* t)) + (call-next-method)))) + (defun source-note-length (note) (- (source-note-end-pos note) (source-note-start-pos note))) @@ -3025,20 +3035,33 @@ (defun read-recording-source (stream &key eofval file-name start-offset map) - "Read a top-level form recording source location notes in MAP" - (if (null map) - (values (read-internal stream nil eofval nil)) - (let* ((recording (list stream map file-name start-offset)) - (*recording-source-streams* (cons recording *recording-source-streams*))) - (declare (dynamic-extent recording *recording-source-streams*)) - (multiple-value-bind (form source-note) (read-internal stream nil eofval nil) - (when (and source-note (not (eq form eofval))) - (assert (null (source-note-source source-note))) - (let ((text (make-string (source-note-length source-note))) - (pos (file-position stream))) - (file-position stream (- (source-note-start-pos source-note) start-offset)) - (read-sequence text stream) - (file-position stream pos) - (setf (source-note-source source-note) text))) - form)))) + "Read a top-level form, perhaps recording source location. +If MAP is NIL, just reads a form as if by READ. +If MAP is non-NIL, returns a second value of a source-note describing the form. +In addition, if MAP is a hash table, it gets filled with source-note's for all +non-atomic nested forms." + (typecase map + (null (values (read-internal stream nil eofval nil) nil)) + (hash-table + (let* ((recording (list stream map file-name (or start-offset 0))) + (*recording-source-streams* (cons recording *recording-source-streams*))) + (declare (dynamic-extent recording *recording-source-streams*)) + (multiple-value-bind (form source-note) (read-internal stream nil eofval nil) + (when (and source-note (not (eq form eofval))) + (assert (null (source-note-source source-note))) + (let ((text (make-string (source-note-length source-note))) + (pos (file-position stream))) + (file-position stream (- (source-note-start-pos source-note) start-offset)) + (read-sequence text stream) + (file-position stream pos) + (setf (source-note-source source-note) text))) + (values form source-note)))) + (t (let* ((start (file-position stream)) + (form (read-internal stream nil eofval nil))) + (values form (and (consp form) + (not (eq form eofval)) + (%make-source-note :form form + :file-name file-name + :start-pos (+ (or start-offset 0) start) + :end-pos (+ (or start-offset 0) (file-position stream))))))))) (defun make-source-note (&key form stream start-pos end-pos subform-notes source) Index: /branches/gz-working/lib/defstruct-lds.lisp =================================================================== --- /branches/gz-working/lib/defstruct-lds.lisp (revision 8462) +++ /branches/gz-working/lib/defstruct-lds.lisp (revision 8463) @@ -257,5 +257,4 @@ ,(if (and predicate (null (sd-type sd))) `',predicate) ,.(if documentation (list documentation))) - (record-source-file ',(sd-name sd) 'structure) ,(%defstruct-compile sd refnames) ;; Wait until slot accessors are defined, to avoid Index: /branches/gz-working/lib/defstruct.lisp =================================================================== --- /branches/gz-working/lib/defstruct.lisp (revision 8462) +++ /branches/gz-working/lib/defstruct.lisp (revision 8463) @@ -97,4 +97,5 @@ (set-documentation name 'type doc)) (puthash name %defstructs% sd) + (record-source-file name 'structure) (when (and predicate (null (sd-type sd))) (puthash predicate %structure-refs% name)) Index: /branches/gz-working/lib/encapsulate.lisp =================================================================== --- /branches/gz-working/lib/encapsulate.lisp (revision 8462) +++ /branches/gz-working/lib/encapsulate.lisp (revision 8463) @@ -584,13 +584,4 @@ res)) -(defmacro with-traces (syms &body body) - `(unwind-protect - (progn - (let ((*trace-output* (make-broadcast-stream))) - ;; if you're tracing ccl internals you'll get trace output as it encapsulates the - ;; functions so hide all the trace output while eval'ing teh trace form itself. - (trace ,@syms)) - ,@body) - (untrace ,@syms))) ;; this week def is the name of an uninterned gensym whose fn-cell is original def Index: /branches/gz-working/lib/nfcomp.lisp =================================================================== --- /branches/gz-working/lib/nfcomp.lisp (revision 8462) +++ /branches/gz-working/lib/nfcomp.lisp (revision 8463) @@ -35,5 +35,5 @@ (defun read-recording-source (stream &key eofval file-name start-offset map) (read stream nil eofval nil))) - +#-BOOTSTRAPPED (defvar *save-source-locations* nil) (defmacro short-fixnum-p (fixnum) @@ -53,5 +53,4 @@ ;they should be in the product just in case we need them for patches.... (defvar *fasl-save-local-symbols* t) -(defvar *fasl-save-source-locations* nil) (defvar *fasl-deferred-warnings* nil) (defvar *fasl-non-style-warnings-signalled-p* nil) @@ -112,4 +111,6 @@ pathname)) +(defvar *fasl-save-source-locations*) + (defun compile-file (src &key output-file (verbose *compile-verbose*) @@ -119,7 +120,7 @@ (target *fasl-target* target-p) (save-local-symbols *fasl-save-local-symbols*) - (save-source-locations *fasl-save-source-locations*) (save-doc-strings *fasl-save-doc-strings*) (save-definitions *fasl-save-definitions*) + (save-source-locations *save-source-locations*) (external-format :default) force) @@ -330,5 +331,6 @@ (defvar *fcomp-output-list*) (defvar *fcomp-toplevel-forms*) -(defvar *fcomp-source-note-map*) +(defvar *fcomp-source-note-map* nil) ;; init to nil as might be ref'd outside read loop by load forms +(defvar *fcomp-covered-functions*) (defvar *fcomp-warnings-header*) (defvar *fcomp-stream-position* nil) @@ -406,8 +408,10 @@ (*fasl-eof-forms* nil) (*loading-file-source-file* (namestring orig-file)) ; why orig-file??? - (*fcomp-source-note-map* (and *fasl-save-source-locations* (make-hash-table))) + (*fcomp-source-note-map* (and (or *record-pc-mapping* *compile-code-coverage*) + (make-hash-table))) + (*fcomp-covered-functions* nil) (eofval (cons nil nil)) (read-package nil) - form) + form source-note) (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*)) ;;This should really be something like `(set-loading-source @@ -432,12 +436,17 @@ (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename) (signal c)))) - (setq form (read-recording-source stream - :eofval eofval - :file-name (or *compile-file-original-truename* (truename stream)) - :start-offset (or *compile-file-original-buffer-offset* 0) - :map *fcomp-source-note-map*))))) + (multiple-value-setq (form source-note) + (read-recording-source stream + :eofval eofval + :file-name (or *compile-file-original-truename* *loading-file-source-file*) + :start-offset (or *compile-file-original-buffer-offset* 0) + :map (or *fcomp-source-note-map* + (and *fasl-save-source-locations* t))))))) (when (eq eofval form) (return)) - (fcomp-form form env processing-mode form) + (fcomp-form form env processing-mode source-note) (setq *fcomp-previous-position* *fcomp-stream-position*)))) + (when *fcomp-covered-functions* + (let ((v (nreverse (coerce *fcomp-covered-functions* 'vector)))) + (fcomp-random-toplevel-form `(setq *code-covered-functions* (cons '(,*loading-file-source-file* . ,v) *code-covered-functions*))))) (while (setq form *fasl-eof-forms*) (setq *fasl-eof-forms* nil) @@ -449,5 +458,5 @@ -(defun fcomp-form (form env processing-mode &optional source +(defun fcomp-form (form env processing-mode &optional source-note &aux print-stuff (load-time (and processing-mode (neq processing-mode :compile-time))) @@ -488,19 +497,19 @@ " (Compiletime)" ""))))))) - (fcomp-form-1 form env processing-mode source))) - -(defun fcomp-form-1 (form env processing-mode &optional source &aux sym body) + (fcomp-form-1 form env processing-mode source-note))) + +(defun fcomp-form-1 (form env processing-mode &optional source-note &aux sym body) (if (consp form) (setq sym (%car form) body (%cdr form))) (case sym (progn - (fcomp-form-list body env processing-mode source)) + (fcomp-form-list body env processing-mode source-note)) (eval-when - (fcomp-eval-when body env processing-mode source)) + (fcomp-eval-when body env processing-mode source-note)) (compiler-let - (fcomp-compiler-let body env processing-mode source)) + (fcomp-compiler-let body env processing-mode source-note)) (locally - (fcomp-locally body env processing-mode source)) + (fcomp-locally body env processing-mode source-note)) (macrolet - (fcomp-macrolet body env processing-mode source)) + (fcomp-macrolet body env processing-mode source-note)) #|;; special case for passing around source-location info (%source-note @@ -516,5 +525,5 @@ (cond ((and (non-nil-symbol-p sym) - (macro-function sym env) + (macro-function sym env) (not (compiler-macro-function sym env)) (not (eq sym '%defvar-init)) ; a macro that we want to special-case @@ -523,10 +532,10 @@ (setq form new)) win)) - (fcomp-form form env processing-mode source)) + (fcomp-form form env processing-mode source-note)) ((and (not *fcomp-inside-eval-always*) (memq sym *fcomp-eval-always-functions*)) (let* ((*fcomp-inside-eval-always* t) (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form))) - (fcomp-form-1 new env processing-mode source))) + (fcomp-form-1 new env processing-mode source-note))) (t (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too)) @@ -534,20 +543,20 @@ (when (and processing-mode (neq processing-mode :compile-time)) (case sym - ((%defconstant) (fcomp-load-%defconstant form env source)) - ((%defparameter) (fcomp-load-%defparameter form env source)) - ((%defvar %defvar-init) (fcomp-load-defvar form env source)) - ((%defun) (fcomp-load-%defun form env source)) + ((%defconstant) (fcomp-load-%defconstant form env source-note)) + ((%defparameter) (fcomp-load-%defparameter form env source-note)) + ((%defvar %defvar-init) (fcomp-load-defvar form env source-note)) + ((%defun) (fcomp-load-%defun form env source-note)) ((set-package %define-package) - (fcomp-random-toplevel-form form env source) + (fcomp-random-toplevel-form form env source-note) (fcomp-compile-toplevel-forms env)) - ((%macro) (fcomp-load-%macro form env source)) - ;; ((%deftype) (fcomp-load-%deftype form source)) - ;; ((define-setf-method) (fcomp-load-define-setf-method form source)) - (t (fcomp-random-toplevel-form form env source))))))))) - -(defun fcomp-form-list (forms env processing-mode source) - (dolist (form forms) (fcomp-form form env processing-mode source))) - -(defun fcomp-compiler-let (form env processing-mode source &aux vars varinits) + ((%macro) (fcomp-load-%macro form env source-note)) + ;; ((%deftype) (fcomp-load-%deftype form source-note)) + ;; ((define-setf-method) (fcomp-load-define-setf-method form source-note)) + (t (fcomp-random-toplevel-form form env source-note))))))))) + +(defun fcomp-form-list (forms env processing-mode source-note) + (dolist (form forms) (fcomp-form form env processing-mode source-note))) + +(defun fcomp-compiler-let (form env processing-mode source-note &aux vars varinits) (fcomp-compile-toplevel-forms env) (dolist (pair (pop form)) @@ -555,15 +564,15 @@ (push (%compile-time-eval (nx-pair-initform pair) env) varinits)) (progv (nreverse vars) (nreverse varinits) - (fcomp-form-list form env processing-mode source) + (fcomp-form-list form env processing-mode source-note) (fcomp-compile-toplevel-forms env))) -(defun fcomp-locally (body env processing-mode source) +(defun fcomp-locally (body env processing-mode source-note) (fcomp-compile-toplevel-forms env) (multiple-value-bind (body decls) (parse-body body env) (let* ((env (augment-environment env :declare (decl-specs-from-declarations decls)))) - (fcomp-form-list body env processing-mode source) + (fcomp-form-list body env processing-mode source-note) (fcomp-compile-toplevel-forms env)))) -(defun fcomp-macrolet (body env processing-mode source) +(defun fcomp-macrolet (body env processing-mode source-note) (fcomp-compile-toplevel-forms env) (let ((outer-env (augment-environment env @@ -578,8 +587,8 @@ outer-env :declare (decl-specs-from-declarations decls)))) - (fcomp-form-list body env processing-mode source) + (fcomp-form-list body env processing-mode source-note) (fcomp-compile-toplevel-forms env))))) -(defun fcomp-symbol-macrolet (body env processing-mode source) +(defun fcomp-symbol-macrolet (body env processing-mode source-note) (fcomp-compile-toplevel-forms env) (let* ((outer-env (augment-environment env :symbol-macro (car body)))) @@ -587,8 +596,8 @@ (let* ((env (augment-environment outer-env :declare (decl-specs-from-declarations decls)))) - (fcomp-form-list body env processing-mode source) + (fcomp-form-list body env processing-mode source-note) (fcomp-compile-toplevel-forms env))))) -(defun fcomp-eval-when (form env processing-mode source &aux (eval-times (pop form))) +(defun fcomp-eval-when (form env processing-mode source-note &aux (eval-times (pop form))) (let* ((compile-time-too (eq processing-mode :compile-time-too)) (compile-time-only (eq processing-mode :compile-time)) @@ -607,11 +616,11 @@ (fcomp-compile-toplevel-forms env) ; always flush the suckers (cond (compile-time-only - (if at-eval-time (fcomp-form-list form env :compile-time source))) + (if at-eval-time (fcomp-form-list form env :compile-time source-note))) (at-load-time (fcomp-form-list form env (if (or at-compile-time (and at-eval-time compile-time-too)) :compile-time-too - :not-compile-time) source)) + :not-compile-time) source-note)) ((or at-compile-time (and at-eval-time compile-time-too)) - (fcomp-form-list form env :compile-time source)))) + (fcomp-form-list form env :compile-time source-note)))) (fcomp-compile-toplevel-forms env)) @@ -642,5 +651,5 @@ symbol)) -(defun fcomp-load-%defconstant (form env source) +(defun fcomp-load-%defconstant (form env source-note) (destructuring-bind (sym valform &optional doc) (cdr form) (unless *fasl-save-doc-strings* @@ -650,7 +659,7 @@ (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluating-p valform))) (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc)) - (fcomp-random-toplevel-form form env source)))) - -(defun fcomp-load-%defparameter (form env source) + (fcomp-random-toplevel-form form env source-note)))) + +(defun fcomp-load-%defparameter (form env source-note) (destructuring-bind (sym valform &optional doc) (cdr form) (unless *fasl-save-doc-strings* @@ -658,8 +667,8 @@ (if (quoted-form-p sym) (setq sym (%cadr sym))) - (let* ((fn (fcomp-function-arg valform env))) + (let* ((fn (fcomp-function-arg valform env source-note))) (if (and (typep sym 'symbol) (or fn (constantp valform))) (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc)) - (fcomp-random-toplevel-form form env source))))) + (fcomp-random-toplevel-form form env source-note))))) ; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here. @@ -668,5 +677,5 @@ ; Hairier initforms could be handled by another fasl operator that takes a thunk ; and conditionally calls it. -(defun fcomp-load-defvar (form env source) +(defun fcomp-load-defvar (form env source-note) (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form) (unless *fasl-save-doc-strings* @@ -677,8 +686,8 @@ (if (and sym-p (not val-p)) (fcomp-output-form $fasl-defvar env sym) - (let* ((fn (if sym-p (fcomp-function-arg valform env)))) + (let* ((fn (if sym-p (fcomp-function-arg valform env source-note)))) (if (and sym-p (or fn (constantp valform))) (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc)) - (fcomp-random-toplevel-form (macroexpand-1 form env) env source))))))) + (fcomp-random-toplevel-form (macroexpand-1 form env) env source-note))))))) (defun define-compile-time-macro (name lambda-expression env) @@ -755,5 +764,5 @@ ))))) -(defun fcomp-load-%defun (form env source) +(defun fcomp-load-%defun (form env source-note) (destructuring-bind (fn &optional doc) (cdr form) (unless *fasl-save-doc-strings* @@ -763,18 +772,18 @@ (setq doc nil))) (if (and (constantp doc) - (setq fn (fcomp-function-arg fn env source))) + (setq fn (fcomp-function-arg fn env source-note))) (progn (setq doc (eval-constant doc)) (fcomp-output-form $fasl-defun env fn doc)) - (fcomp-random-toplevel-form form env source)))) - -(defun fcomp-load-%macro (form env source &aux fn doc) + (fcomp-random-toplevel-form form env source-note)))) + +(defun fcomp-load-%macro (form env source-note &aux fn doc) (verify-arg-count form 1 2) (if (and (constantp (setq doc (caddr form))) - (setq fn (fcomp-function-arg (cadr form) env source))) + (setq fn (fcomp-function-arg (cadr form) env source-note))) (progn (setq doc (eval-constant doc)) (fcomp-output-form $fasl-macro env fn doc)) - (fcomp-random-toplevel-form form env source))) + (fcomp-random-toplevel-form form env source-note))) (defun define-compile-time-structure (sd refnames predicate env) @@ -799,5 +808,5 @@ (nx-transform form env)) -(defun fcomp-random-toplevel-form (form env source) +(defun fcomp-random-toplevel-form (form env source-note) (unless (constantp form) (unless (or (atom form) @@ -811,5 +820,5 @@ (while args (multiple-value-bind (arg win) (fcomp-transform (%car args) env) - (when (or (setq lfun (fcomp-function-arg arg env source)) + (when (or (setq lfun (fcomp-function-arg arg env source-note)) win) (when lfun (setq arg `',lfun)) @@ -821,13 +830,13 @@ (push form *fcomp-toplevel-forms*))) -(defun fcomp-function-arg (expr env &optional source) +(defun fcomp-function-arg (expr env &optional source-note) (when (consp expr) (cond ((and (eq (%car expr) 'nfunction) (symbolp (car (%cdr expr))) (lambda-expression-p (car (%cddr expr)))) - (fcomp-named-function (%caddr expr) (%cadr expr) env source)) + (fcomp-named-function (%caddr expr) (%cadr expr) env source-note)) ((and (eq (%car expr) 'function) (lambda-expression-p (car (%cdr expr)))) - (fcomp-named-function (%cadr expr) nil env source))))) + (fcomp-named-function (%cadr expr) nil env source-note))))) (defun fcomp-compile-toplevel-forms (env) @@ -868,5 +877,5 @@ ;;; file. The result will not be funcalled. This really shouldn't bother ;;; making an lfun, but it's simpler this way... -(defun fcomp-named-function (def name env &optional source) +(defun fcomp-named-function (def name env &optional source-note) (let* ((env (new-lexical-environment env))) (multiple-value-bind (lfun warnings) @@ -874,5 +883,5 @@ :name name :env env - :source source + :source-note source-note :keep-lambda *fasl-save-definitions* :keep-symbols *fasl-save-local-symbols* @@ -882,4 +891,6 @@ :target *fasl-target*) (fcomp-signal-or-defer-warnings warnings env) + (when (logbitp $lfbits-code-coverage-bit (lfun-bits lfun)) + (push lfun *fcomp-covered-functions*)) lfun))) Index: /branches/gz-working/library/lispequ.lisp =================================================================== --- /branches/gz-working/library/lispequ.lisp (revision 8462) +++ /branches/gz-working/library/lispequ.lisp (revision 8463) @@ -141,5 +141,5 @@ (defconstant $lfbits-info-bit 23) (defconstant $lfbits-trampoline-bit 24) -(defconstant $lfbits-evaluated-bit 25) +(defconstant $lfbits-code-coverage-bit 25) (defconstant $lfbits-cm-bit 26) ; combined-method (defconstant $lfbits-nextmeth-bit 26) ; or call-next-method with method-bit