source: trunk/version-control.lisp @ 3

Revision 3, 3.1 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: (WOOD) -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; version-control.lisp
6;; Check for old persistent heap version. Update if we know how.
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17;;
18
19;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;
21;; Modification History
22;;
23;; -------------  0.96
24;; -------------  0.95
25;; -------------  0.94
26;; -------------  0.93
27;; -------------  0.9
28;; -------------  0.8
29;; 12/17/93 bill  New file
30
31(in-package :wood)
32
33; This function is called by open-pheap.
34; It currently knows how to update from version 1 to version 2.
35(defun check-pheap-version (pheap)
36  (let ((disk-cache (pheap-disk-cache pheap)))
37    (multiple-value-bind (version imm?) (dc-%svref disk-cache $root-vector $pheap.version)
38      (unless (and imm? (eql version $version-number))
39        (cond ((eql version #x504801) (dc-fix-symbols disk-cache))
40              (t (error "Unknown version number in ~s" pheap)))
41        (setf (dc-%svref disk-cache $root-vector $pheap.version t) $version-number))))
42  $version-number)
43
44
45; version 2 fixed a bug that caused symbols whose storage crossed a
46; page boundary to be stored incorrectly. This functions updates
47; a version 1 pheap to version 2.
48(defun dc-fix-symbols (disk-cache)
49  (let* ((page-size (disk-cache-page-size disk-cache))
50         (size (disk-cache-size disk-cache))
51         (pages (floor size page-size))
52         (page 1)
53         (addr page-size)
54         (count 0))
55    (loop
56      (when (>= page pages) (return))
57      (let* ((area (read-pointer disk-cache (+ addr $block-segment-ptr)))
58             (next-page (+ addr page-size)))
59        (when (dc-vector-subtype-p disk-cache area $v_segment)
60          (let ((header (read-long disk-cache (- next-page 8))))
61            (when (eql header $symbol-header)
62              (unless (eql area
63                           (read-pointer
64                            disk-cache (+ next-page $block-segment-ptr)))
65                (let* ((sym (- next-page 6))
66                       (package (read-pointer disk-cache (+ sym $sym_package)))
67                       (values (read-pointer disk-cache (+ sym $sym_values))))
68                  (setf (read-pointer disk-cache
69                                      (addr+ disk-cache sym $sym_package))
70                        package)
71                  (setf (read-pointer disk-cache
72                                      (addr+ disk-cache sym $sym_values))
73                        values)
74                  (setf (read-pointer disk-cache (+ next-page $block-segment-ptr))
75                        area)
76                  (incf count))))))
77        (incf page)
78        (setq addr next-page)))
79    count))
80;;;    1   3/10/94  bill         1.8d247
81;;;    2   3/23/95  bill         1.11d010
Note: See TracBrowser for help on using the repository browser.