Changeset 14058 for branches/qres
- Timestamp:
- Jul 27, 2010, 2:21:17 AM (11 years ago)
- Location:
- branches/qres/ccl
- Files:
-
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/qres/ccl
- Property svn:mergeinfo changed
/trunk/source merged: 13891,13929,13942,13964-13966,14044
- Property svn:mergeinfo changed
-
branches/qres/ccl/compiler/lambda-list.lisp
r13070 r14058 35 35 (defun function-source-note (fn) 36 36 (getf (%lfun-info fn) '%function-source-note)) 37 38 (defun %function-acode-string (fn) 39 (getf (%lfun-info fn) '%function-acode-string)) 37 40 38 41 (defun uncompile-function (fn) -
branches/qres/ccl/compiler/nx-basic.lisp
r13565 r14058 77 77 ;; the note that was being compiled when this note was emitted. 78 78 parent-note 79 ;; start/end position in the acode string for the toplevel lfun containing this code note. 80 acode-range 79 81 #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused. 80 82 form) … … 484 486 485 487 486 (defun cons-var (name &optional (bits 0))487 (%istruct 'var name bits nil nil nil nil nilnil))488 (defun nx-cons-var (name &optional (bits 0)) 489 (%istruct 'var name bits nil nil nil nil 0 nil)) 488 490 489 491 … … 492 494 (report-bad-arg env 'lexical-environment)) 493 495 (check-environment-args variable symbol-macro function macro) 494 (let* ((vars (mapcar #' cons-var variable))496 (let* ((vars (mapcar #'nx-cons-var variable)) 495 497 (symbol-macros (mapcar #'(lambda (s) 496 498 (let* ((sym (car s))) … … 499 501 (not (eq (variable-information sym env) :special))) 500 502 (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym)) 501 (let ((v ( cons-var (car s))))503 (let ((v (nx-cons-var (car s)))) 502 504 (setf (var-expansion v) (cons :symbol-macro (cadr s))) 503 505 v))) … … 707 709 (cdr (assq name (defenv.structrefs defenv)))))) 708 710 711 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 712 ;; 713 ;; For code coverage, pretty-print acode to string and store position info in code notes. 714 ;; 715 ;; decomp-acode can also be used separately for debugging. 716 ;; 717 (defmacro dbg-assert (form) 718 #+debug-code-notes `(assert ,form)) 719 720 (defvar *acode-right-margin* 120) 721 (defvar *nx-pprint-stream* nil) 722 (defvar *nx-acode-inner-refs* :default) 723 (defvar *nx-acode-refs-counter* 0) 724 725 (defun nx-pprinting-p (stream) 726 (and *nx-pprint-stream* 727 (typep stream 'xp-stream) 728 (slot-value stream 'xp-structure) 729 (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure))))) 730 731 (defstruct acode-ref 732 object) 733 734 (defstruct (acode-afunc-ref (:include acode-ref)) 735 afunc 736 index) 737 738 (defun nx-record-code-coverage-acode (afunc) 739 (assert *nx-current-code-note*) 740 (let* ((form->note (make-hash-table :test #'eq)) 741 (*nx-acode-inner-refs* nil) 742 (*nx-acode-refs-counter* 0) 743 (form (decomp-acode (afunc-acode afunc) 744 :prettify t 745 :hook (lambda (acode form &aux (note (acode-note acode))) 746 ;; For expressions within without-compiling-code-coverage, there is a source 747 ;; note and not a code note, so need to check for code note explicitly. 748 (when (code-note-p note) 749 (dbg-assert (null (gethash form form->note))) 750 (dbg-assert (null (code-note-acode-range note))) 751 (setf (gethash form form->note) note))))) 752 (package *package*) 753 (string (with-standard-io-syntax 754 (with-output-to-string (*nx-pprint-stream*) 755 (let* ((*package* package) 756 (*print-right-margin* *acode-right-margin*) 757 (*print-case* :downcase) 758 (*print-readably* nil)) 759 (pprint-recording-positions 760 form *nx-pprint-stream* 761 (lambda (form open-p pos) 762 (let* ((note (gethash form form->note)) 763 (range (and note (code-note-acode-range note)))) 764 (when note 765 (cond (open-p 766 (dbg-assert (null range)) 767 (setf (code-note-acode-range note) 768 (encode-file-range pos pos))) 769 (t 770 (dbg-assert (not (null range))) 771 (multiple-value-bind (start end) 772 (decode-file-range range) 773 (declare (ignorable end)) 774 (dbg-assert (eq start end)) 775 (setf (code-note-acode-range note) 776 (encode-file-range start pos)))))))))))))) 777 (iterate store ((afunc afunc)) 778 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string) 779 (loop for inner in (afunc-inner-functions afunc) 780 unless (getf (afunc-lfun-info inner) '%function-acode-string) 781 do (store inner))) 782 afunc)) 783 784 (defmethod print-object ((ref acode-afunc-ref) stream) 785 (if (nx-pprinting-p stream) 786 (let ((index (acode-afunc-ref-index ref))) 787 (when index ;; referenced multiple times. 788 (if (eql index 0) ;; never referenced before? 789 (format stream "#~d=" 790 (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*))) 791 ;; If not first reference, just point back. 792 (return-from print-object (format stream "#~d#" index)))) 793 (write-1 (acode-afunc-ref-object ref) stream)) 794 (call-next-method))) 795 796 (defmethod print-object ((ref acode-ref) stream) 797 (if (nx-pprinting-p stream) 798 (write-1 (acode-ref-object ref) stream) 799 (call-next-method))) 800 801 (defun decomp-ref (obj) 802 (if (and (listp *nx-acode-inner-refs*) ;; code coverage case 803 (not (acode-p obj))) 804 (make-acode-ref :object obj) 805 obj)) 806 807 (defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp") 808 809 (defvar *decomp-hook* nil) 810 811 (defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*)) 812 (let ((*decomp-hook* hook) 813 (*decomp-prettify* prettify)) 814 (decomp-form acode))) 815 816 (defun decomp-form (acode) 817 (cond ((eq acode *nx-t*) t) 818 ((eq acode *nx-nil*) nil) 819 (t (let* ((op (car acode)) 820 (num (length *next-nx-operators*)) 821 (name (when (and (fixnump op) 822 (<= 0 op) 823 (setq op (logand op operator-id-mask)) 824 (< op num)) 825 (car (nth (- num op 1) *next-nx-operators*)))) 826 (new (decomp-using-name (or name op) (cdr acode)))) 827 (when *decomp-hook* 828 (funcall *decomp-hook* acode new)) 829 new)))) 830 831 832 (defun decomp-afunc (afunc) 833 (setq afunc (require-type afunc 'afunc)) 834 (dbg-assert (afunc-acode afunc)) 835 (if (listp *nx-acode-inner-refs*) ;; code coverage case 836 (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc))) 837 (if ref ;; seen before, mark that multiply referenced. 838 (setf (acode-afunc-ref-index ref) 0) 839 (push (setq ref (make-acode-afunc-ref :afunc afunc 840 :object (decomp-form (afunc-acode afunc)))) 841 *nx-acode-inner-refs*)) 842 ref) 843 afunc)) 844 845 (defun decomp-var (var) 846 (decomp-ref (var-name (require-type var 'var)))) 847 848 (defun decomp-formlist (formlist) 849 (mapcar #'decomp-form formlist)) 850 851 (defun decomp-arglist (arglist) 852 (destructuring-bind (stack-forms register-forms) arglist 853 (nconc (decomp-formlist stack-forms) 854 (nreverse (decomp-formlist register-forms))))) 855 856 (defun decomp-lambda-list (req opt rest keys auxen &optional whole) 857 (flet ((decomp-arg (var) 858 (if (acode-p var) 859 (destructuring-bind (op whole req opt rest keys auxen) var 860 (assert (eq op (%nx1-operator lambda-list))) ;; fake 861 (decomp-lambda-list req opt rest keys auxen whole)) 862 (decomp-var var)))) 863 (let ((whole (and whole (list '&whole (decomp-arg whole)))) 864 (reqs (mapcar #'decomp-arg req)) 865 (opts (when opt (cons '&optional (apply #'mapcar 866 (lambda (var init supp) 867 (if (and (not supp) (eq init *nx-nil*)) 868 (decomp-arg var) 869 (list* (decomp-arg var) 870 (decomp-form init) 871 (and supp (list (decomp-arg supp)))))) 872 opt)))) 873 (rest (when rest (list '&rest (decomp-arg rest)))) 874 (keys (when keys 875 (destructuring-bind (aok vars supps inits keyvect) keys 876 (nconc 877 (when vars 878 (cons '&key (map 'list (lambda (var supp init key) 879 (let* ((sym (decomp-arg var)) 880 (arg (if (and (symbolp sym) (eq (make-keyword sym) key)) 881 sym 882 (list key sym)))) 883 (if (and (not supp) (eq init *nx-nil*) (eq arg sym)) 884 sym 885 (list* arg 886 (decomp-form init) 887 (and supp (list (decomp-arg supp))))))) 888 vars supps inits keyvect))) 889 (when aok (list '&allow-other-keys)))))) 890 (auxen (when (car auxen) 891 (cons '&aux (apply #'mapcar 892 (lambda (var init) 893 (if (eq init *nx-nil*) 894 (decomp-arg var) 895 (list (decomp-arg var) (decomp-form init)))) 896 auxen))))) 897 (nconc whole reqs opts rest keys auxen)))) 898 899 (defmacro defdecomp (names arglist &body body) 900 (let ((op-var (car arglist)) 901 (args-vars (cdr arglist)) 902 (op-decls nil) 903 (args-var (gensym))) 904 (multiple-value-bind (body decls) (parse-body body nil) 905 ;; Kludge but good enuff for here 906 (setq decls (loop for decl in decls 907 collect (cons (car decl) 908 (loop for exp in (cdr decl) 909 do (when (and (consp exp) (member op-var (cdr exp))) 910 (push (list (car exp) op-var) op-decls)) 911 collect (cons (car exp) (remove op-var (cdr exp))))))) 912 `(progn 913 ,@(loop for name in (if (atom names) (list names) names) 914 collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var) 915 (declare ,@op-decls) 916 (destructuring-bind ,args-vars ,args-var 917 ,@decls 918 ,@body))))))) 919 920 ;; Default method 921 (defmethod decomp-using-name (op forms) 922 `(,op ,@(decomp-formlist forms))) 923 924 ;; not real op, kludge generated below for lambda-bind 925 (defdecomp keyref (op index) 926 `(,op ,index)) 927 928 (defdecomp immediate (op imm) 929 (when *decomp-prettify* 930 (setq op 'quote)) 931 `(,op ,imm)) 932 933 (defdecomp fixnum (op raw-fixnum) 934 (declare (ignore op)) 935 (decomp-ref raw-fixnum)) 936 937 (defdecomp %function (op symbol) 938 (when *decomp-prettify* 939 (setq op 'function)) 940 `(,op ,symbol)) 941 942 (defdecomp simple-function (op afunc) 943 (when *decomp-prettify* 944 (setq op 'function)) 945 `(,op ,(decomp-afunc afunc))) 946 947 (defdecomp closed-function (op afunc) 948 (when *decomp-prettify* 949 (setq op 'function)) 950 `(,op ,(decomp-afunc afunc))) 951 952 (defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list) 953 `(,op ,@(decomp-formlist form-list))) 954 955 (defdecomp multiple-value-call (op fn form-list) 956 `(,op ,(decomp-form fn) ,@(decomp-formlist form-list))) 957 958 (defdecomp vector (op formlist) 959 `(,op ,@(decomp-formlist formlist))) 960 961 (defdecomp (%gvector list* %err-disp) (op arglist) 962 `(,op ,@(decomp-arglist arglist))) 963 964 (defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall 965 i386-ff-call ff-call eabi-ff-call poweropen-ff-call) 966 (op target argspecs argvals resultspec &rest rest) 967 `(,op 968 ,(decomp-form target) 969 ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals) 970 ,resultspec 971 ,@rest)) 972 973 (defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms) 974 (if (eq (acode-immediate-operand cc) :eq) 975 `(,op ,@(decomp-formlist forms)) 976 `(,op ,(decomp-form cc) ,@(decomp-formlist forms)))) 977 978 (defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p) 979 `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p)))) 980 981 (defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p) 982 `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p)) 983 984 (defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms) 985 `(,op ,bits ,@(decomp-formlist forms))) 986 987 (defdecomp call (op fn arglist &optional spread-p) 988 (setq op (if spread-p 'apply 'funcall)) 989 `(,op ,(decomp-form fn) ,@(decomp-arglist arglist))) 990 991 (defdecomp lexical-function-call (op afunc arglist &optional spread-p) 992 (setq op (if *decomp-prettify* 993 (if spread-p 'apply 'funcall) 994 (if spread-p 'lexical-apply 'lexical-funcall))) 995 `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist))) 996 997 (defdecomp self-call (op arglist &optional spread-p) 998 (declare (Ignore op)) 999 `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist))) 1000 1001 (defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol) 1002 (if *decomp-prettify* 1003 (decomp-ref symbol) 1004 `(,op ,symbol))) 1005 1006 (defdecomp (setq-special setq-free global-setq) (op symbol form) 1007 (when *decomp-prettify* 1008 (setq op 'setq)) 1009 `(,op ,symbol ,(decomp-form form))) 1010 1011 (defdecomp inherited-arg (op var) 1012 `(,op ,(decomp-var var))) 1013 1014 (defdecomp lexical-reference (op var) 1015 (if *decomp-prettify* 1016 (decomp-var var) 1017 `(,op ,(decomp-var var)))) 1018 1019 (defdecomp setq-lexical (op var form) 1020 (when *decomp-prettify* 1021 (setq op 'setq)) 1022 `(,op ,(decomp-var var) ,(decomp-form form))) 1023 1024 (defdecomp (let let* with-downward-closures) (op vars vals body p2decls) 1025 (declare (ignore p2decls)) 1026 `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals) 1027 ,(decomp-form body))) 1028 1029 (defdecomp %decls-body (op form p2decls) 1030 (declare (ignore p2decls)) 1031 `(,op ,(decomp-form form))) 1032 1033 (defdecomp multiple-value-bind (op vars form body p2decls) 1034 (declare (ignore p2decls)) 1035 `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body))) 1036 1037 1038 (defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note) 1039 (declare (ignore p2decls code-note)) 1040 (when *decomp-prettify* 1041 (setq op 'lambda)) 1042 `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body))) 1043 1044 (defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p) 1045 (declare (ignore ll p2decls cdr-p)) 1046 `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body))) 1047 1048 (defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls) 1049 (declare (ignore keys-p p2decls)) 1050 (when (find-if #'fixnump (cadr auxen)) 1051 (destructuring-bind (vars vals) auxen 1052 (setq auxen (list vars 1053 (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals))))) 1054 (let ((lambda-list (decomp-lambda-list req nil rest nil auxen))) 1055 `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body)))) 1056 1057 (defdecomp (flet labels) (op vars afuncs body p2decls) 1058 (declare (ignore p2decls)) 1059 `(,op ,(mapcar (lambda (var afunc) 1060 (list (decomp-var var) (decomp-afunc afunc))) 1061 vars afuncs) 1062 ,(decomp-form body))) 1063 1064 (defdecomp local-go (op tag) 1065 (when *decomp-prettify* 1066 (setq op 'go)) 1067 `(,op ,(car tag))) 1068 1069 (defdecomp tag-label (op &rest tag) 1070 (if *decomp-prettify* 1071 (decomp-ref (car tag)) 1072 `(,op ,(car tag)))) 1073 1074 (defdecomp local-tagbody (op tags forms) 1075 (declare (ignore tags)) 1076 (when *decomp-prettify* 1077 (setq op 'tagbody)) 1078 `(,op ,@(decomp-formlist forms))) 1079 1080 (defdecomp local-block (op block body) 1081 (when *decomp-prettify* 1082 (setq op 'block)) 1083 `(,op ,(car block) ,(decomp-form body))) 1084 1085 (defdecomp local-return-from (op block form) 1086 (when *decomp-prettify* 1087 (setq op 'return-from)) 1088 `(,op ,(car block) ,(decomp-form form))) 1089 709 1090 ; end -
branches/qres/ccl/compiler/nx0.lisp
r14049 r14058 61 61 62 62 (defvar *nx1-operators* (make-hash-table :size 300 :test #'eq)) 63 64 65 ; The compiler can (generally) use temporary vectors for VARs.66 (defun nx-cons-var (name &optional (bits 0))67 (%istruct 'var name bits nil nil nil nil 0 nil))68 69 70 71 63 72 64 (defvar *nx-lambdalist* (make-symbol "lambdalist")) … … 1445 1437 (setf (afunc-vcells p) *nx1-vcells*) 1446 1438 (setf (afunc-fcells p) *nx1-fcells*) 1439 (when *nx-current-code-note* 1440 (when (null q) ;; toplevel functions only 1441 (nx-record-code-coverage-acode p))) 1447 1442 (let* ((warnings (merge-compiler-warnings *nx-warnings*)) 1448 1443 (name *nx-cur-func-name*)) -
branches/qres/ccl/level-1/l1-reader.lisp
r14049 r14058 3087 3087 (cons start-pos end-pos)))) 3088 3088 3089 (defun decode-file-range (range) 3090 (when range 3091 (if (consp range) 3092 (values (car range) (cdr range)) 3093 (let ((start-pos (ash range -14))) 3094 (values start-pos (+ start-pos (logand range #x3FFF))))))) 3095 3089 3096 (defun source-note-text (source-note &optional start end) 3090 3097 (when source-note -
branches/qres/ccl/lib/pprint.lisp
r11834 r14058 175 175 (conses-with-cars (make-hash-table :test #'eq) :type hash-table) 176 176 (structures (make-hash-table :test #'eq) :type (or null hash-table)) 177 (others nil :type list)) 177 (others nil :type list) 178 (commit-hook nil)) 178 179 179 180 ;The list and the hash-tables contain entries of the … … 199 200 :conses-with-cars new-conses-with-cars 200 201 :structures new-structures 201 :others (copy-list (others table))))) 202 :others (copy-list (others table)) 203 :commit-hook (commit-hook table)))) 202 204 203 205 … … 939 941 (maybe-too-large xp qleft queue linel))) 940 942 (T T)) ;(:linear :unconditional :mandatory) 941 (output-line xp qleft) 942 (setup-for-next-line xp qleft)))) 943 (output-line-and-setup-for-next xp qleft)))) 943 944 (setf (xp-qleft xp) (setq qleft (qnext qleft)))) 944 945 (when flush-out? (flush xp))))) … … 947 948 948 949 (defun flush (xp) 949 (let ((ostream (xp-out-stream xp))) 950 (let ((ostream (xp-out-stream xp)) 951 (len (xp-buffer-ptr xp))) 952 (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*)) 953 (funcall (commit-hook *print-pprint-dispatch*) xp len 0)) 950 954 (when ostream 951 (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp)))952 (incf (xp-buffer-offset xp) (xp-buffer-ptr xp))953 (incf (xp-charpos xp) (xp-buffer-ptr xp))955 (write-string (xp-buffer xp) ostream :start 0 :end len)) 956 (incf (xp-buffer-offset xp) len) 957 (incf (xp-charpos xp) len) 954 958 (setf (xp-buffer-ptr xp) 0))) 955 959 … … 968 972 ;This prints out a line of stuff. 969 973 970 (defun output-line (xp Qentry) 971 (flet ((find-not-char-reverse (buffer out-point) 972 (declare (type simple-base-string buffer) (type fixnum out-point)) 973 (do ((i (%i- out-point 1) (%i- i 1))) 974 ((%i< i 0) nil) 975 (when (or (neq (schar buffer i) #\Space) 976 ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be 977 ;; quoted; don't bother checking for that, no big harm leaving the space even if 978 ;; not totally necessary). 979 (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\))) 980 (return i))))) 981 (let* ((queue (xp-queue xp)) 982 (out-point (BP<-TP xp (xpq-pos queue Qentry))) 983 (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point)) 984 (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point) 985 (last-non-blank (%i+ 1 last-non-blank)) 986 (T 0))) 987 (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp)))))) 988 (when line-limit-exit 989 (setf (xp-buffer-ptr xp) end) ;truncate pending output. 990 (write-string+++ " .." xp 0 3) 991 (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp)) 992 (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp)) 993 (setf (xp-qleft xp) (qnext (xp-qright xp))) 994 ;(setq *abbreviation-happened* '*print-lines*) 995 (throw 'line-limit-abbreviation-exit T)) 996 (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp))) 997 (let ((bstream (xp-out-stream xp))) 998 (when bstream 999 (write-string (xp-buffer xp) bstream :start 0 :end end) 1000 (stream-write-char bstream #\newline)))))) 1001 1002 (defun setup-for-next-line (xp Qentry) 974 (defun output-line-and-setup-for-next (xp Qentry) 1003 975 (let* ((queue (xp-queue xp)) 1004 976 (out-point (BP<-TP xp (xpq-pos queue Qentry))) 1005 (prefix-end 1006 (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh)) 1007 (non-blank-prefix-ptr xp)) 1008 (T (prefix-ptr xp)))) 1009 (change (- prefix-end out-point))) 1010 (declare (fixnum out-point prefix-end change)) 977 (unconditional-p (memq (xpq-kind queue Qentry) '(:fresh :unconditional))) 978 (end (if unconditional-p 979 out-point 980 (let ((buffer (xp-buffer xp))) 981 (declare (type simple-base-string buffer)) 982 (do ((i (%i- out-point 1) (%i- i 1))) 983 ((%i< i 0) 0) 984 (when (or (neq (schar buffer i) #\Space) 985 ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be 986 ;; quoted; don't bother checking for that, no big harm leaving the space even if 987 ;; not totally necessary). 988 (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\))) 989 (return (%i+ i 1))))))) 990 (prefix-end 991 (if unconditional-p (non-blank-prefix-ptr xp) (prefix-ptr xp))) 992 (old-ptr (xp-buffer-ptr xp)) 993 (new-ptr (%i+ old-ptr (%i- prefix-end out-point))) 994 (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp)))))) 995 (when line-limit-exit 996 (setf (xp-buffer-ptr xp) end) ;truncate pending output. 997 (write-string+++ " .." xp 0 3) 998 (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp)) 999 (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp)) 1000 (setf (xp-qleft xp) (qnext (xp-qright xp))) 1001 ;(setq *abbreviation-happened* '*print-lines*) 1002 (throw 'line-limit-abbreviation-exit T)) 1003 (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp))) 1004 (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*)) 1005 (funcall (commit-hook *print-pprint-dispatch*) xp out-point prefix-end)) 1006 (let ((bstream (xp-out-stream xp))) 1007 (when bstream 1008 (write-string (xp-buffer xp) bstream :start 0 :end end) 1009 (stream-write-char bstream #\newline))) 1011 1010 (setf (xp-charpos xp) 0) 1012 (when (plusp change) ;almost never happens 1013 (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change) 1014 #.buffer-min-size #.buffer-entry-size)) 1011 (when (%i> new-ptr old-ptr) ;almost never happens 1012 (xp-check-size (xp-buffer xp) new-ptr #.buffer-min-size #.buffer-entry-size)) 1013 (setf (xp-buffer-ptr xp) new-ptr) 1014 (decf (xp-buffer-offset xp) (- prefix-end out-point)) 1015 1015 (let ((buffer (xp-buffer xp))) 1016 (replace buffer buffer :start1 prefix-end 1017 :start2 out-point :end2 (xp-buffer-ptr xp)) 1016 (replace buffer buffer :start1 prefix-end :start2 out-point :end2 old-ptr) 1018 1017 (replace buffer (xp-prefix xp) :end2 prefix-end) 1019 (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change)) 1020 (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change)) 1021 (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh))) 1018 (unless unconditional-p 1022 1019 (setf (section-start-line xp) (xp-line-no xp)))))) 1020 1021 1023 1022 1024 1023 (defun set-indentation-prefix (xp new-position) … … 1310 1309 (defmethod stream-finish-output ((xp xp-structure)) 1311 1310 (attempt-to-output xp t t)) 1311 1312 (defun pprint-recording-positions (form stream recorder) 1313 ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines. 1314 (let* ((old-table *print-pprint-dispatch*) 1315 (rec-pending nil) 1316 (record (require-type recorder 'function))) 1317 (flet ((rec-pprint (xp object) 1318 #+gz (assert (or (null rec-pending) 1319 (<= (caar rec-pending) (xp-buffer-ptr xp)))) 1320 (let ((real-printer (get-printer object old-table))) 1321 (when real-printer 1322 (push (list* (xp-buffer-ptr xp) t object) rec-pending) 1323 (funcall real-printer xp object) 1324 (push (list* (xp-buffer-ptr xp) nil object) rec-pending)))) 1325 (rec-commit (xp commited inserted) 1326 (loop with change = (- inserted commited) 1327 as last = nil then pending 1328 as pending = rec-pending then (cdr pending) while pending 1329 do (when (<= (caar pending) commited) ;; commit the rest. 1330 (if last 1331 (setf (cdr last) nil) 1332 (setf rec-pending nil)) 1333 (loop with start = (stream-position (xp-out-stream xp)) 1334 for (offset open-p . object) in (nreverse pending) 1335 do (funcall record object open-p (+ start offset))) 1336 (return nil)) 1337 do (incf (caar pending) change)))) 1338 (let* ((*print-pretty* t) 1339 (*print-circle* nil) 1340 (*print-length* nil) 1341 (*print-level* nil) 1342 (*print-lines* nil) 1343 (*print-miser-width* nil) 1344 (*read-suppress* nil) 1345 (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit))) 1346 (set-pprint-dispatch 'cons #'rec-pprint) 1347 (write-1 form stream) 1348 #+gz (assert (null rec-pending)))) 1349 form)) 1350 1312 1351 1313 1352 -
branches/qres/ccl/library/cover.lisp
r13685 r14058 47 47 without-compiling-code-coverage)) 48 48 49 (defconstant $not-executed-style 2) 50 (defconstant $totally-covered-style 5) 51 (defconstant $partially-covered-style 6) 49 (defconstant $no-style 0) 50 (defconstant $not-executed-style 1) 51 (defconstant $totally-covered-style 2) 52 (defconstant $partially-covered-style 3) 52 53 53 54 (defparameter *file-coverage* ()) … … 55 56 (defparameter *emitted-code-notes* (make-hash-table :test #'eq)) 56 57 (defparameter *entry-code-notes* (make-hash-table :test #'eq)) 57 58 (defparameter *code-note-acode-strings* (make-hash-table :test #'eq)) 59 60 (defparameter *coverage-acode-queue* nil) 58 61 59 62 (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) … … 83 86 (defun entry-code-note-p (note) 84 87 (gethash note *entry-code-notes*)) 88 89 (defun code-note-acode-string (note) 90 (gethash note *code-note-acode-strings*)) 85 91 86 92 (defun map-function-coverage (lfun fn &optional refs) … … 94 100 do (map-function-coverage imm fn refs)))) 95 101 96 (defun get-function-coverage (fn refs )102 (defun get-function-coverage (fn refs acode) 97 103 (let ((entry (function-entry-code-note fn)) 98 (refs (cons fn refs))) 104 (refs (cons fn refs)) 105 (acode (or (%function-acode-string fn) acode))) 99 106 (declare (dynamic-extent refs)) 100 107 (when entry 101 108 (assert (eq fn (gethash entry *entry-code-notes* fn))) 102 (setf (gethash entry *entry-code-notes*) fn)) 109 (setf (gethash entry *entry-code-notes*) fn) 110 (when acode 111 (setf (gethash entry *code-note-acode-strings*) acode))) 103 112 (nconc 104 113 (and entry (list fn)) 105 114 (lfunloop for imm in fn 106 115 when (code-note-p imm) 107 do (setf (gethash imm *emitted-code-notes*) t) 116 do (progn 117 (setf (gethash imm *emitted-code-notes*) t) 118 (when acode 119 (setf (gethash imm *code-note-acode-strings*) acode))) 108 120 when (and (functionp imm) 109 121 (not (memq imm refs))) 110 nconc (get-function-coverage imm refs )))))122 nconc (get-function-coverage imm refs acode))))) 111 123 112 124 (defun code-covered-info.file (data) (and (consp data) (car data))) … … 128 140 (clrhash *emitted-code-notes*) 129 141 (clrhash *entry-code-notes*) 142 (clrhash *code-note-acode-strings*) 130 143 (loop for data in *code-covered-functions* 131 144 do (let* ((file (code-covered-info.file data)) … … 138 151 (delete-duplicates 139 152 (loop for fn across toplevel-functions 140 nconc (get-function-coverage fn nil )))153 nconc (get-function-coverage fn nil nil))) 141 154 toplevel-functions) 142 155 *file-coverage*)))) … … 146 159 while parent 147 160 do (pushnew n (gethash parent *coverage-subnotes*)) 148 until (emitted-code-note-p parent)))) 161 until (emitted-code-note-p parent))) 162 (let ((hash (make-hash-table :test #'eq))) 163 ;; distribute entry acode to the toplevel source note it belongs to. 164 (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn) 165 as acode = (code-note-acode-string entry) 166 as sn = (entry-note-unambiguous-source entry) 167 as toplevel-sn = (function-source-form-note fn) 168 do (when sn 169 (assert toplevel-sn) 170 (let* ((pos (source-note-end-pos sn)) 171 (cell (assq acode (gethash toplevel-sn hash)))) 172 (if cell 173 (setf (cdr cell) (max (cdr cell) pos)) 174 (push (cons acode pos) (gethash toplevel-sn hash)))))) 175 (setf *coverage-acode-queue* 176 (sort (loop for sn being the hash-key of hash using (hash-value alist) 177 collect (cons (source-note-end-pos sn) 178 (mapcar #'car (sort alist #'< :key #'cdr)))) 179 #'< :key #'car)))) 149 180 150 181 #+debug … … 159 190 (when (entry-code-note-p note) 160 191 (format t " (Entry to ~s)" (entry-code-note-p note))) 192 (when (code-note-acode-range note) 193 (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note)) 194 (format t " [acode ~a:~a]" s e))) 161 195 (format t "~%") 162 196 (when (code-note-p note) … … 573 607 574 608 609 (defun style-for-coverage (coverage) 610 (case coverage 611 ((full) $totally-covered-style) 612 ((nil) $not-executed-style) 613 (t $partially-covered-style))) 614 575 615 (defun fill-with-text-style (coverage location-note styles) 576 (let ((style (case coverage 577 ((full) $totally-covered-style) 578 ((nil) $not-executed-style) 579 (t $partially-covered-style)))) 580 (fill styles style 581 :start (source-note-start-pos location-note) 582 :end (source-note-end-pos location-note)))) 616 (fill styles (style-for-coverage coverage) 617 :start (source-note-start-pos location-note) 618 :end (source-note-end-pos location-note))) 583 619 584 620 (defun update-text-styles (note styles) … … 642 678 (return sn)))) 643 679 644 645 (defun colorize-function (fn styles &optional refs) 680 (defun colorize-acode (fn acode-styles) 681 (let* ((acode (%function-acode-string fn)) 682 (note (function-entry-code-note fn)) 683 (range (and note (code-note-acode-range note)))) 684 (when (and acode range) 685 (let ((styles (or (gethash acode acode-styles) 686 (setf (gethash acode acode-styles) 687 (make-array (length acode) 688 :initial-element $no-style 689 :element-type '(unsigned-byte 2)))))) 690 (iterate update ((note note)) 691 (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note)) 692 (when (and start 693 (setq start (position-if-not #'whitespacep acode :start start :end end))) 694 (fill styles (style-for-coverage (code-note-code-coverage note)) 695 :start start 696 :end end))) 697 (loop for sub in (coverage-subnotes note) 698 unless (entry-code-note-p sub) 699 do (update sub))))))) 700 701 (defun colorize-function (fn styles acode-styles &optional refs) 646 702 (let* ((note (function-entry-code-note fn)) 647 703 (source (function-source-form-note fn)) … … 650 706 ;; Colorize the body of the function 651 707 (when note 652 (colorize-source-note note styles)) 708 (colorize-source-note note styles) 709 (colorize-acode fn acode-styles)) 653 710 ;; And now any subfunction references 654 711 (lfunloop for imm in fn … … 664 721 (warn "Ignoring ref to ~s from ~s" imm fn) 665 722 nil))) 666 do (colorize-function imm styles refs))))723 do (colorize-function imm styles acode-styles refs)))) 667 724 668 725 (defun report-file-coverage (index-file coverage html-stream external-format) … … 676 733 string))) 677 734 (styles (make-array (length source) 678 :initial-element 0 679 :element-type '(unsigned-byte 2)))) 680 (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) 681 (print-file-coverage-report index-file html-stream coverage styles source) 735 :initial-element $no-style 736 :element-type '(unsigned-byte 2))) 737 (acode-styles (make-hash-table :test #'eq))) 738 (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage)) 739 (print-file-coverage-report index-file html-stream coverage styles acode-styles source) 682 740 (format html-stream "</body></html>"))) 683 741 684 (defun print-file-coverage-report (index-file html-stream coverage styles source)742 (defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source) 685 743 (let ((*print-case* :downcase)) 686 744 (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%" … … 694 752 695 753 (format html-stream "<div class='key'><b>Key</b><br />~%") 696 (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) 697 (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) 698 (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style) 699 (format html-stream "<p></p><div><code>~%") 700 701 (flet ((line (line) 702 (unless (eql line 0) 703 (format html-stream "</span>")) 704 (incf line) 705 (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code> " line) 706 line)) 707 (loop with line = (line 0) with col = 0 708 for last-style = nil then style 709 for char across source 710 for style across styles 711 do (unless (eq style last-style) 712 (when last-style 713 (format html-stream "</span>")) 714 (format html-stream "<span class='state-~a'>" style)) 754 (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style) 755 (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style) 756 (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style) 757 (format html-stream "</div><p></p>~%") 758 759 ;; Output source intertwined with acode 760 (iterate output ((start 0) (line 0)) 761 (format html-stream "<div class='source'><code>") 762 (let ((next (car *coverage-acode-queue*))) 763 (multiple-value-bind (end last-line) 764 (output-styled html-stream source styles 765 :start start 766 :line line 767 :limit (car next)) 768 (format html-stream "</code></div>~%") 769 (when (and next end (<= (car next) end)) 770 (destructuring-bind (pos . strings) next 771 (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~ 772 <div class='acode' id='a~:*~d'><code>" pos) 773 (loop for acode in strings as styles = (gethash acode acode-styles) 774 do (assert styles) 775 do (output-styled html-stream acode styles) 776 do (fresh-line html-stream)) 777 (format html-stream "</code></div><hr/>~%")) 778 (pop *coverage-acode-queue*) 779 (output (1+ end) last-line))))))) 780 781 (defun output-styled (html-stream source styles &key (start 0) line limit) 782 (let ((last-style $no-style) 783 (col 0) 784 (line line)) 785 (labels ((outch (char) 786 (if (eql char #\Tab) 787 (dotimes (i (- 8 (mod col 8))) 788 (incf col) 789 (write-string " " html-stream)) 790 (progn 791 (incf col) 792 (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe 793 (write-char char html-stream) 794 (format html-stream "&#~D;" (char-code char)))))) 795 (start-line () 796 (when line 797 (incf line) 798 (format html-stream "<span class='line'>~A</span>" line)) 799 (write-char #\space html-stream) 800 (setq col 0)) 801 (set-style (new) 802 (unless (eq last-style new) 803 (unless (eq last-style $no-style) (format html-stream "</span>")) 804 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new)) 805 (setq last-style new))) 806 (end-line () 807 (set-style $no-style) 808 (format html-stream "~%"))) 809 (declare (inline outch start-line end-line)) 810 (unless limit (setq limit (length source))) 811 (start-line) 812 (loop 813 for pos from start below (length source) 814 as char = (aref source pos) as style = (aref styles pos) 815 do (set-style style) 715 816 do (case char 716 817 ((#\Newline) 717 (setq style nil) 718 (setq col 0) 719 (setq line (line line))) 720 ((#\Space) 721 (incf col) 722 (write-string " " html-stream)) 723 ((#\Tab) 724 (dotimes (i (- 8 (mod col 8))) 725 (incf col) 726 (write-string " " html-stream))) 818 (end-line) 819 (when (<= limit pos) 820 (return (values pos line))) 821 (start-line)) 727 822 (t 728 (incf col) 729 (if (alphanumericp char) 730 (write-char char html-stream) 731 (format html-stream "&#~D;" (char-code char)))))) 732 (format html-stream "</code></div>")))) 823 (outch char))) 824 finally (end-line))))) 733 825 734 826 … … 875 967 (defun write-coverage-styles (html-stream) 876 968 (format html-stream "<style type='text/css'> 877 *.st ate-~a { background-color: #ffaaaa }878 *.st ate-~a { background-color: #aaffaa }879 *.st ate-~a { background-color: #44dd44 }880 div.key { margin: 20px; width: 88ex }881 div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;969 *.st~a { background-color: #ffaaaa } 970 *.st~a { background-color: #aaffaa } 971 *.st~a { background-color: #44dd44 } 972 *.key { margin: 20px; width: 88ex } 973 *.source { width: 120ex; background-color: #eeeeee; padding-left: 5px; 882 974 /* border-style: solid none none none; border-width: 1px; 883 border-color: #dddddd */ } 884 885 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } 975 border-color: #dddddd */ 976 white-space: pre; } 977 978 *.acode { border-left: 1px dashed #c0c0c0; 979 margin-top: 1ex; 980 margin-left: 6ex; 981 margin-bottom: 2ex; 982 white-space: pre; 983 display: none; } 984 985 *.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; } 986 987 *.toggle { font-size: small; } 886 988 887 989 table.summary tr.head-row { background-color: #aaaaff } … … 892 994 table.summary tr.subheading { background-color: #aaaaff} 893 995 table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; } 894 </style>" 996 997 </style> 998 999 <script type='text/javascript'> 1000 function swap (id) { 1001 var acode = document.getElementById('a' + id); 1002 var prompt = document.getElementById('p' + id); 1003 if (acode.style.display == 'block') { 1004 acode.style.display = 'none'; 1005 prompt.innerHTML = 'Show expansion'; 1006 } else { 1007 acode.style.display = 'block'; 1008 prompt.innerHTML = 'Hide expansion'; 1009 } 1010 } 1011 </script> 1012 " 895 1013 $not-executed-style 896 1014 $partially-covered-style 897 1015 $totally-covered-style 898 1016 )) 1017
Note: See TracChangeset
for help on using the changeset viewer.