← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to pcl/impl/gcl/gcl-patches.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
pcl/impl/gcl/gcl-patches.lisp
 
1
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
 
2
;;;
 
3
;;; *************************************************************************
 
4
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
 
5
;;; All rights reserved.
 
6
;;;
 
7
;;; Use and copying of this software and preparation of derivative works
 
8
;;; based upon this software are permitted.  Any distribution of this
 
9
;;; software or derivative works must comply with all applicable United
 
10
;;; States export control laws.
 
11
;;; 
 
12
;;; This software is made available AS IS, and Xerox Corporation makes no
 
13
;;; warranty about the software, its performance or its conformity to any
 
14
;;; specification.
 
15
;;; 
 
16
;;; Any person obtaining a copy of this software is requested to send their
 
17
;;; name and post office or electronic mail address to:
 
18
;;;   CommonLoops Coordinator
 
19
;;;   Xerox PARC
 
20
;;;   3333 Coyote Hill Rd.
 
21
;;;   Palo Alto, CA 94304
 
22
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
 
23
;;;
 
24
;;; Suggestions, comments and requests for improvements are also welcome.
 
25
;;; *************************************************************************
 
26
;;;
 
27
 
 
28
 
 
29
(in-package "COMPILER")
 
30
 
 
31
;; do evaluation of top level forms at compile time.
 
32
(eval-when (compile eval load)
 
33
(setq  *EVAL-WHEN-COMPILE* t)
 
34
)
 
35
 
 
36
(pushnew :turbo-closure *features*)
 
37
(pushnew :turbo-closure-env-size *features*)
 
38
;; patch around compiler bug.
 
39
 
 
40
 
 
41
(let ((rset "int Rset;
 
42
"))
 
43
  (unless (search rset compiler::*cmpinclude-string*)
 
44
      (setq compiler::*cmpinclude-string*
 
45
            (concatenate 'string rset compiler::*cmpinclude-string*))))
 
46
 
 
47
(when (get 'si::basic-wrapper 'si::s-data)
 
48
  (pushnew :new-kcl-wrapper *features*)
 
49
  (pushnew :structure-wrapper *features*))
 
50
  
 
51
 
 
52
 
 
53
 
 
54
#+akcl
 
55
(progn
 
56
 
 
57
(unless (fboundp 'real-c2lambda-expr-with-key)
 
58
  (setf (symbol-function 'real-c2lambda-expr-with-key)
 
59
        (symbol-function 'c2lambda-expr-with-key)))
 
60
 
 
61
(defun c2lambda-expr-with-key (lambda-list body)
 
62
  (declare (special *sup-used*))
 
63
  (setq *sup-used* t)
 
64
  (real-c2lambda-expr-with-key lambda-list body))
 
65
 
 
66
 
 
67
;There is a bug in the implementation of *print-circle* that
 
68
;causes some akcl debugging commands (including :bt and :bl)
 
69
;to cause the following error when PCL is being used:
 
70
;Unrecoverable error: value stack overflow.
 
71
 
 
72
;When a CLOS object is printed, travel_push_object ends up
 
73
;traversing almost the whole class structure, thereby overflowing
 
74
;the value-stack.
 
75
 
 
76
;from lsp/debug.lsp.
 
77
;*print-circle* is badly implemented in kcl.
 
78
;it has two separate problems that should be fixed:
 
79
;  1. it traverses the printed object putting all objects found
 
80
;     on the value stack (rather than in a hash table or some
 
81
;     other structure; this is a problem because the size of the value stack
 
82
;     is fixed, and a potentially unbounded number of objects
 
83
;     need to be traversed), and
 
84
;  2. it blindly traverses all slots of any
 
85
;     kind of structure including std-object structures.
 
86
;     This is safe, but not always necessary, and is very time-consuming
 
87
;     for CLOS objects (because it will always traverse every class).
 
88
 
 
89
;For now, avoid using *print-circle* T when it will cause problems.
 
90
 
 
91
 
 
92
 
 
93
(eval-when (compile eval )
 
94
(defmacro si::f (op &rest args)
 
95
    `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
 
96
 
 
97
(defmacro si::fb (op &rest args)
 
98
    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
 
99
)
 
100
 
 
101
(defun si::display-env (n env)
 
102
  (do ((v (reverse env) (cdr v)))
 
103
      ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
 
104
    (or (and (consp (car v))
 
105
             (listp (cdar v)))
 
106
        (return))
 
107
    (let ((*print-circle* (can-use-print-circle-p (cadar v))))
 
108
      (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
 
109
 
 
110
(defun si::display-compiled-env ( plength ihs &aux
 
111
                                      (base (si::ihs-vs ihs))
 
112
                                      (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
 
113
  (format si::*display-string* "")
 
114
  (do ((i base )
 
115
       (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
 
116
      ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
 
117
    (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
 
118
    (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
 
119
            (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
 
120
            (si::fb < (setq i (si::f + i 1)) end)))))
 
121
 
 
122
(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
 
123
(defentry objnull-p (object) (object "objnull_p"))
 
124
 
 
125
(defun can-use-print-circle-p (x)
 
126
  (catch 'can-use-print-circle-p
 
127
    (can-use-print-circle-p1 x nil)))
 
128
 
 
129
(defun can-use-print-circle-p1 (x so-far)
 
130
  (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
 
131
       (if (member x so-far)
 
132
           (throw 'can-use-print-circle-p t)
 
133
           (let ((so-far (cons x so-far)))
 
134
             (flet ((can-use-print-circle-p (x)
 
135
                      (can-use-print-circle-p1 x so-far)))
 
136
               (typecase x
 
137
                 (vector  (or (not (eq 't (array-element-type x)))
 
138
                              (every #'can-use-print-circle-p x)))
 
139
                 (cons    (and (can-use-print-circle-p (car x))
 
140
                               (can-use-print-circle-p (cdr x))))
 
141
                 (array   (or (not (eq 't (array-element-type x)))
 
142
                              (let* ((rank (array-rank x))
 
143
                                     (dimensions (make-list rank)))
 
144
                                (dotimes (i rank)
 
145
                                  (setf (nth i dimensions) (array-dimension x i)))
 
146
                                (or (member 0 dimensions)
 
147
                                    (do ((cursor (make-list rank :initial-element 0)))
 
148
                                        (nil)
 
149
                                      (declare (:dynamic-extent cursor))
 
150
                                      (unless (can-use-print-circle-p
 
151
                                               (apply #'aref x cursor))
 
152
                                        (return nil))
 
153
                                      (when (si::increment-cursor cursor dimensions)
 
154
                                        (return t)))))))
 
155
                 (t (or (not (si:structurep x))
 
156
                        (let* ((def (si:structure-def x))
 
157
                               (name (si::s-data-name def))
 
158
                               (len (si::s-data-length def))
 
159
                               (pfun (si::s-data-print-function def)))
 
160
                          (and (null pfun)
 
161
                               (dotimes (i len t)
 
162
                                 (unless (can-use-print-circle-p
 
163
                                          (si:structure-ref x name i))
 
164
                                   (return nil)))))))))))))
 
165
 
 
166
(defun si::apply-display-fun (display-fun  n lis)  
 
167
  (let ((*print-length* si::*debug-print-level*)
 
168
        (*print-level* si::*debug-print-level*)
 
169
        (*print-pretty* nil)
 
170
        (*PRINT-CASE* :downcase)
 
171
        (*print-circle* nil)
 
172
        )
 
173
    (setf (fill-pointer si::*display-string*) 0)
 
174
    (format si::*display-string* "{")
 
175
    (funcall display-fun n lis)
 
176
    (when (si::fb > (fill-pointer si::*display-string*) n)
 
177
      (setf (fill-pointer si::*display-string*) n)
 
178
      (format si::*display-string* "..."))
 
179
 
 
180
    (format si::*display-string* "}")
 
181
    )
 
182
  si::*display-string*
 
183
  )
 
184
 
 
185
;The old definition of this had a bug:
 
186
;sometimes it returned without calling mv-values.
 
187
(defun si::next-stack-frame (ihs &aux line-info li i k na)
 
188
  (cond ((si::fb < ihs si::*ihs-base*)
 
189
         (si::mv-values nil nil nil nil nil))
 
190
        ((let (fun)
 
191
           ;; next lower visible ihs
 
192
           (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
 
193
           (setq na fun)
 
194
           (cond ((and (setq line-info (get fun 'si::line-info))
 
195
                       (do ((j (si::f + ihs 1) (si::f - j 1))
 
196
                            (form ))
 
197
                           ((<= j i) nil)
 
198
                         (setq form (si::ihs-fun j))
 
199
                         (cond ((setq li (si::get-line-of-form form line-info))
 
200
                                (return-from si::next-stack-frame 
 
201
                                  (si::mv-values
 
202
                                   i fun li
 
203
                                   ;; filename
 
204
                                   (car (aref line-info 0))
 
205
                                   ;;environment
 
206
                                   (list (si::vs (setq k (si::ihs-vs j)))
 
207
                                         (si::vs (1+ k))
 
208
                                         (si::vs (+ k 2)))))))))))))
 
209
        ((and (not (special-form-p na))
 
210
              (not (get na 'si::dbl-invisible))
 
211
              (fboundp na))
 
212
         (si::mv-values i na nil nil
 
213
                    (if (si::ihs-not-interpreted-env i)
 
214
                        nil
 
215
                        (let ((i (si::ihs-vs i)))
 
216
                          (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
 
217
        (t (si::mv-values nil nil nil nil nil))))
 
218
)
 
219
 
 
220
 
 
221
 
 
222
 
 
223
 
 
224
 
 
225