source: trunk/source/compiler/lambda-list.lisp @ 14044

Last change on this file since 14044 was 14044, checked in by gz, 9 years ago

support for reporting code coverage of acode, needs more testing

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19(in-package "CCL")
20
21
22;;; Compiler functions needed elsewhere
23
24(defun %lfun-info-index (fn)
25  (and (compiled-function-p fn)
26       (let ((bits (lfun-bits fn)))
27         (declare (fixnum bits))
28         (and (logbitp $lfbits-info-bit bits)
29               (%i- (uvsize (function-to-function-vector fn))
30                              (if (logbitp $lfbits-noname-bit bits) 2 3))))))
31(defun %lfun-info (fn)
32  (let* ((index (%lfun-info-index fn)))
33    (if index (%svref (function-to-function-vector fn) index))))
34
35(defun function-source-note (fn)
36  (getf (%lfun-info fn) '%function-source-note))
37
38(defun %function-acode-string (fn)
39  (getf (%lfun-info fn) '%function-acode-string))
40
41(defun uncompile-function (fn)
42  (getf (%lfun-info fn) 'function-lambda-expression ))
43
44;;; used-by: backtrace, arglist
45(defun function-symbol-map (fn)
46  (getf (%lfun-info fn) 'function-symbol-map))
47
48(defun find-source-note-at-pc (fn pc)
49  ;(declare (values source-note start-pc end-pc))
50  (let* ((function-note (function-source-note fn))
51         (pc-source-map (getf (%lfun-info fn) 'pc-source-map))
52         (best-guess -1)
53         (best-length 0)
54         (len (length pc-source-map)))
55    (declare (fixnum best-guess best-length len))
56    (when (and function-note pc-source-map)
57      (do ((q 0 (+ q 4)))
58          ((= q len))
59        (declare (fixnum q))
60        (let* ((pc-start (aref pc-source-map q))
61               (pc-end (aref pc-source-map (%i+ q 1))))
62          (declare (fixnum pc-start pc-end))
63          (when (and (<= pc-start pc)
64                     (< pc pc-end)
65                     (or (eql best-guess -1)
66                         (< (%i- pc-end pc-start) best-length)))
67            (setf best-guess q
68                  best-length (- pc-end pc-start)))))
69      (unless (eql best-guess -1)
70        (values
71          (let ((def-pos (source-note-start-pos function-note)))
72            (make-source-note :source function-note
73                              :filename (source-note-filename function-note)
74                              :start-pos (+ def-pos (aref pc-source-map (+ best-guess 2)))
75                              :end-pos (+ def-pos (aref pc-source-map (+ best-guess 3)))))
76          (aref pc-source-map best-guess)
77          (aref pc-source-map (+ best-guess 1)))))))
78
79;;; Lambda-list utilities
80
81
82
83
84
85;;; Lambda-list verification:
86
87;;; these things MUST be compiled.
88(eval-when (:load-toplevel)
89
90(defvar *structured-lambda-list* nil)
91
92
93
94
95(defun parse-body (body env &optional (doc-string-allowed t) &aux
96   decls
97   doc
98   (tail body)
99   form)
100  (declare (ignore env))
101  (loop
102   (if (endp tail) (return))  ; otherwise, it has a %car and a %cdr
103   (if (and (stringp (setq form (%car tail))) (%cdr tail))
104    (if doc-string-allowed
105     (setq doc form)
106     (return))
107    (if (not (and (consp form) (symbolp (%car form)))) 
108     (return)
109     (if (eq (%car form) 'declare)
110      (push form decls)
111      (return))))
112   (setq tail (%cdr tail)))
113  (return-from parse-body (values tail (nreverse decls) doc)))
114
115) ; end of eval-when (load)
116
117;;; End of verify-lambda-list.lisp
Note: See TracBrowser for help on using the repository browser.