source: branches/rme-logops/compiler/lambda-list.lisp @ 15706

Last change on this file since 15706 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.6 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 uncompile-function (fn)
39  (getf (%lfun-info fn) 'function-lambda-expression ))
40
41;;; used-by: backtrace, arglist
42(defun function-symbol-map (fn)
43  (getf (%lfun-info fn) 'function-symbol-map))
44
45(defun find-source-note-at-pc (fn pc)
46  ;(declare (values source-note start-pc end-pc))
47  (let* ((function-note (function-source-note fn))
48         (pc-source-map (getf (%lfun-info fn) 'pc-source-map))
49         (best-guess -1)
50         (best-length 0)
51         (len (length pc-source-map)))
52    (declare (fixnum best-guess best-length len))
53    (when (and function-note pc-source-map)
54      (do ((q 0 (+ q 4)))
55          ((= q len))
56        (declare (fixnum q))
57        (let* ((pc-start (aref pc-source-map q))
58               (pc-end (aref pc-source-map (%i+ q 1))))
59          (declare (fixnum pc-start pc-end))
60          (when (and (<= pc-start pc)
61                     (< pc pc-end)
62                     (or (eql best-guess -1)
63                         (< (%i- pc-end pc-start) best-length)))
64            (setf best-guess q
65                  best-length (- pc-end pc-start)))))
66      (unless (eql best-guess -1)
67        (values
68          (let ((def-pos (source-note-start-pos function-note)))
69            (make-source-note :source function-note
70                              :filename (source-note-filename function-note)
71                              :start-pos (+ def-pos (aref pc-source-map (+ best-guess 2)))
72                              :end-pos (+ def-pos (aref pc-source-map (+ best-guess 3)))))
73          (aref pc-source-map best-guess)
74          (aref pc-source-map (+ best-guess 1)))))))
75
76;;; Lambda-list utilities
77
78
79
80
81
82;;; Lambda-list verification:
83
84;;; these things MUST be compiled.
85(eval-when (:load-toplevel)
86
87(defvar *structured-lambda-list* nil)
88
89
90
91
92(defun parse-body (body env &optional (doc-string-allowed t) &aux
93   decls
94   doc
95   (tail body)
96   form)
97  (declare (ignore env))
98  (loop
99   (if (endp tail) (return))  ; otherwise, it has a %car and a %cdr
100   (if (and (stringp (setq form (%car tail))) (%cdr tail))
101    (if doc-string-allowed
102     (setq doc form)
103     (return))
104    (if (not (and (consp form) (symbolp (%car form)))) 
105     (return)
106     (if (eq (%car form) 'declare)
107      (push form decls)
108      (return))))
109   (setq tail (%cdr tail)))
110  (return-from parse-body (values tail (nreverse decls) doc)))
111
112) ; end of eval-when (load)
113
114;;; End of verify-lambda-list.lisp
Note: See TracBrowser for help on using the repository browser.