1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
(in-package 'si)
(require "FASDMACROS" "../cmpnew/fasdmacros.lsp")
;; (test '(a (1)) 2 12.0) --> ((a (1)) 2 12.0)
(defmacro dprint (x)
`(if (and (boundp 'debug) debug)
(format t "~%The value of ~a is ~s" ',x ,x)))
(defun keep (x) (setq sil x))
(defun test (&rest l &aux tab)
(with-open-file (st "/tmp/foo.l"
:direction :output )
(let* ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
(declare (special *fd*))
(si::find-sharing-top l tab)
; (preprocess l tab)
(sloop::sloop for v in l
do
(write-fasd-top v fd)
finally (close-fasd fd))))
(test-in))
(defun preprocess1(lis table)
(cond ((symbolp lis)
(and lis
(let ((tem (gethash lis table)))
(cond (tem
(if (< (the fixnum tem) 0)
(setf (gethash lis table) (the fixnum (+ (the fixnum tem) -1)))))
(t (setf (gethash lis table) -1))))))
((consp lis)
(preprocess1 (car lis) table)
(preprocess1 (cdr lis) table))
((and (arrayp lis)
(eq (array-element-type lis) t))
(sloop::sloop for i below (length lis)
do (preprocess1 (aref (the (array t) lis) i) table)))
((and (arrayp lis)
(eq (array-element-type lis) t))
(sloop::sloop for i below (length lis)
do (preprocess1 (aref (the (array t) lis) i) table)))
(t nil)))
(defun preprocess (lis table &aux freq)
(preprocess1 lis table)
(sloop:sloop for (ke val) in-table table
with m = 0 declare (fixnum m)
do ;(print (list ke val))
(cond((> (the fixnum val) 0)
(SETQ m (the fixnum (+ 1 m))))
((< (the fixnum val) -1)
(remhash ke table)
(push (cons val ke) freq)))
finally (sloop::loop-return
(sort freq '> :key 'car ))))
(defun test-in ()
(with-open-file (st "/tmp/foo.l" :direction :input)
(let ((fdin (open-fasd st :input (setq eof '(nil)) (keep (make-array 10)))))
(sloop while (not (eq eof (setq tem (read-fasd-top fdin))))
collect tem
finally
(dprint fdin)
(close-fasd fdin)))))
(defun try-write (file &aux (tab (make-hash-table :test 'eq)) (eof '(nil)))
(with-open-file (st file)
(with-open-file (st1 "/tmp/foo.l" :direction :output)
(sloop while (not (eq eof (setq tem (read st nil eof)))) with fd
collect (file-position st1)
do(clrhash tab)
(setq fd (open-fasd st1 :output nil tab))
; (let ((prp (preprocess tem tab)))
; (dprint prp))
(write-fasd-top tem fd)
(close-fasd fd)
(dprint tab)
))))
(defvar *differed* nil)
(defun try-read (file pos &aux (tab (make-array 10)) (eof '(nil)))
(with-open-file (st file)
(with-open-file (st1 "/tmp/foo.l")
(sloop while (not (eq eof (setq tem (read st nil eof)))) with fd with re
for u in pos
do (file-position st1 u)
(setq fd (open-fasd st1 :input eof tab))
(sloop::sloop for i below (length tab) do (setf (aref (the (array (t)) tab) i) nil))
(setq re (read-fasd-top fd))
(dprint re)
(unless (equalp tem re)
(push (list tem re) *differed*))
; (assert (eq eof (read-fasd-top fd)))
(close-fasd fd)))))
(defun try (file)
(let ((pos (try-write file)))
(try-read file pos)
(print file)
(system (format nil "cat ~a | wc ; cat /tmp/foo.l | wc " (namestring file)))
))
(defvar *table* (make-hash-table :test 'eq))
(defun do-share (x)
(si::find-sharing x *table*))
(defun read-data-file (file)
(let ((pack-ops))
(set-dispatch-macro-character #\# #\!
#'(lambda (st a b ) (setq pack-ops (read st nil nil) )))
(with-open-file (st file)
(let ((tem (read st nil nil)))
(list pack-ops tem)))))
(defun write-out-data (lis fil)
(with-open-file (st fil :direction :output)
(let ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
(find-sharing-top lis (fasd-table fd))
(write-fasd-top (car lis) fd)
(write-fasd-top (second lis) fd)
; (close-fasd fd)
fd)))
;; To convert an ascii .data file to a fasd one.
;(setq bil (si::read-data-file "vmlisp.data") her nil)
;(SI::WRITE-OUT-DATA1 (SECOND BIL) (FIRST BIL) "/tmp/foo.l")
(defun write-out-data1 (data-vec pack-ops fil)
(with-open-file (st fil :direction :output)
(let ((compiler::*data* (list data-vec nil pack-ops))
(compiler::*compiler-output-data* st)
(compiler::*fasd-data* (list (open-fasd st :output nil nil))))
(compiler::wt-fasd-data-file)
(car compiler::*fasd-data*))))
;(setq dirs (directory "/public/spad/libraries/A*/index.KAF*"))
;(mapcar 'try dirs)
|
