1
;;; CMPWT Output routines.
3
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
5
;; This file is part of GNU Common Lisp, herein referred to as GCL
7
;; GCL is free software; you can redistribute it and/or modify it under
8
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9
;; the Free Software Foundation; either version 2, or (at your option)
12
;; GCL is distributed in the hope that it will be useful, but WITHOUT
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
15
;; License for more details.
17
;; You should have received a copy of the GNU Library General Public License
18
;; along with GCL; see the file COPYING. If not, write to the Free Software
19
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(in-package 'compiler)
24
(eval-when (compile eval)
25
(require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp")
28
(defmacro data-vector () `(car *data*))
29
(defmacro data-inits () `(second *data*))
30
(defmacro data-package-ops () `(third *data*))
34
(defun wt-comment (message &optional (symbol nil))
36
/* " *compiler-output1*)
37
(princ message *compiler-output1*)
39
(let ((s (symbol-name symbol)))
41
(dotimes** (n (length s))
42
(let ((c (schar s n)))
43
(declare (character c))
45
(princ c *compiler-output1*))))))
52
(cond ((or (stringp form) (integerp form) (characterp form))
53
(princ form *compiler-output1*))
54
((or (typep form 'long-float)
55
(typep form 'short-float))
56
(format *compiler-output1* "~10,,,,,,'eG" form))
62
(let ((fun (get (car form) 'wt)))
64
(apply fun (cdr form))
65
(cmpiler-error "The location ~s is undefined." form))))
66
(t (princ form *compiler-output2*)))
71
(defvar *hash-eq* nil)
72
(defun memoized-hash-equal (x depth);FIXME implement all this in lisp
73
(declare (fixnum depth))
74
(unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq)))
75
(or (gethash x *hash-eq*)
76
(setf (gethash x *hash-eq*)
79
(logxor (setq depth (the fixnum (1+ depth)))
80
(memoized-hash-equal (car x) depth)
81
(memoized-hash-equal (cdr x) depth))
82
(si::hash-equal x depth))))))
84
(defun push-data-incf (x)
85
(vector-push-extend (cons (memoized-hash-equal x -1000) x) (data-vector))
88
(defun wt-data1 (expr)
89
(let ((*print-radix* nil)
95
(*print-case* :downcase)
98
;;This forces the printer to add the float type in the .data file.
99
(*READ-DEFAULT-FLOAT-FORMAT* t)
100
(si::*print-package* t)
101
(si::*print-structure* t))
102
(terpri *compiler-output-data*)
103
(prin1 expr *compiler-output-data*)))
105
(defun verify-data-vector(vec &aux v)
106
(dotimes (i (length vec))
107
(setq v (aref vec i))
108
(let ((has (memoized-hash-equal (cdr v) -1000)))
109
(cond ((not (eql (car v) has))
110
(cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v)))))
111
(setf (aref vec i) (cdr v)))
115
(defun add-init (x &optional endp)
116
(let ((tem (cons (memoized-hash-equal x -1000) x)))
119
(nconc (data-inits) (list tem))
120
(cons tem (data-inits) )))
123
(defun wt-data-file ()
124
(verify-data-vector (data-vector))
125
(let* ((vec (coerce (nreverse (data-inits)) 'vector)))
126
(verify-data-vector vec)
127
(setf (aref (data-vector) (- (length (data-vector)) 1))
128
(cons 'si::%init vec))
129
(setf (data-package-ops) (nreverse (data-package-ops)))
133
(format *compiler-output-data* " ~%#(")
134
(dolist (v (data-package-ops))
135
(format *compiler-output-data* "#! ")
137
(wt-data1 (data-vector))
138
(format *compiler-output-data* "~%)~%")
141
(defun wt-fasd-data-file ( &aux (x (data-vector)) tem)
142
; (si::find-sharing-top (data-package-ops) (fasd-table (car *fasd-data*)))
143
(si::find-sharing-top x (fasd-table (car *fasd-data*)))
144
(cond ((setq tem (data-package-ops))
146
(put-op d_eval_skip *compiler-output-data*)
147
(si::write-fasd-top v (car *fasd-data*)))))
148
(si::write-fasd-top x (car *fasd-data*))
149
; (sloop::sloop for (k v) in-table (fasd-table (car *fasd-data*))
150
; when (>= v 0) do (print (list k v)))
151
(si::close-fasd (car *fasd-data*)))
152
(defun wt-data-begin ())
153
(defun wt-data-end ())
154
(defun wt-data-package-operation (x)
155
(push x (data-package-ops)))
157
(defmacro wt (&rest forms &aux (fl nil))
158
(dolist** (form forms (cons 'progn (reverse (cons nil fl))))
160
(push `(princ ,form *compiler-output1*) fl)
161
(push `(wt1 ,form) fl))))
163
(defmacro wt-h (&rest forms &aux (fl nil))
164
(cond ((endp forms) '(princ "
165
" *compiler-output2*))
166
((stringp (car forms))
167
(dolist** (form (cdr forms)
168
(list* 'progn `(princ ,(concatenate 'string "
169
" (car forms)) *compiler-output2*) (reverse (cons nil fl))))
171
(push `(princ ,form *compiler-output2*) fl)
172
(push `(wt-h1 ,form) fl))))
173
(t (dolist** (form forms
174
(list* 'progn '(princ "
175
" *compiler-output2*) (reverse (cons nil fl))))
177
(push `(princ ,form *compiler-output2*) fl)
178
(push `(wt-h1 ,form) fl))))))
180
(defmacro wt-nl (&rest forms &aux (fl nil))
181
(cond ((endp forms) '(princ "
182
" *compiler-output1*))
183
((stringp (car forms))
184
(dolist** (form (cdr forms)
185
(list* 'progn `(princ ,(concatenate 'string "
186
" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
188
(push `(princ ,form *compiler-output1*) fl)
189
(push `(wt1 ,form) fl))))
190
(t (dolist** (form forms
191
(list* 'progn '(princ "
192
" *compiler-output1*) (reverse (cons nil fl))))
194
(push `(princ ,form *compiler-output1*) fl)
195
(push `(wt1 ,form) fl))))))
197
(defmacro wt-nl1 (&rest forms &aux (fl nil))
198
(cond ((endp forms) '(princ "
199
" *compiler-output1*))
200
((stringp (car forms))
201
(dolist** (form (cdr forms)
202
(list* 'progn `(princ ,(concatenate 'string "
203
" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
205
(push `(princ ,form *compiler-output1*) fl)
206
(push `(wt1 ,form) fl))))
207
(t (dolist** (form forms
208
(list* 'progn '(princ "
209
" *compiler-output1*) (reverse (cons nil fl))))
211
(push `(princ ,form *compiler-output1*) fl)
212
(push `(wt1 ,form) fl))))))
added
removed
.pc/2.6.10pre-test-17/cmpnew/gcl_cmpwt.lsp
