source: trunk/load-wood.lisp @ 3

Revision 3, 9.2 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;; load-wood.lisp
6;; Load this file and evaluate (wood::load-wood)
7;; You may need to edit the definition of the "wood" logical host.
8;;
9;; Copyright © 1996 Digitool, Inc.
10;; Copyright © 1992-1995 Apple Computer, Inc.
11;; All rights reserved.
12;; Permission is given to use, copy, and modify this software provided
13;; that Digitool is given credit in all derivative works.
14;; This software is provided "as is". Digitool makes no warranty or
15;; representation, either express or implied, with respect to this software,
16;; its quality, accuracy, merchantability, or fitness for a particular
17;; purpose.
18;;
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; Modification History
23;;
24;; 04/11/97 bill  compile-and-load checks for "Wrong PFSL version" as well
25;;                as "Wrong FASL version".
26;; -------------  0.961
27;; 09/20/96 bill  The WOOD package definition mentions the imported symbols as symbols,
28;;                not strings, for versions of MCL that don't already include them (e.g. 3.9).
29;; -------------  0.96
30;; 07/20/96 bill  import databases-locked-p, with-databases-unlocked, funcall-with-databases-unlocked
31;;                from CCL.
32;;                Don't load break-loop-patch if ccl::databases-locked-p is fbound
33;; 07/09/96 bill  AlanR's fix to (setf (logical-pathname-translations "wood") ...)
34;;                (pathname-directory ...) -> (or (pathname-directory ...) '(:absolute))
35;; -------------  0.95
36;; 06/04/96 bill  load-wood loads break-loop-patch
37;; 05/09/96 bill  export with-databases-unlocked and databases-locked-p
38;; -------------  0.94 = MCL-PPC 3.9
39;; 03/21/96 bill  compile-and-load resignals any error it doesn't recognize
40;; 03/09/96 bill  say ccl::*.fasl-pathname* instead of ".fasl".
41;; -------------  0.93
42;; 08/11/95 bill  translate this file's pathname to a physical one when
43;;                defining the "wood" logical pathname to prevent
44;;                a recursive definition.
45;; 08/11/95 bill  compile-and-load deletes fasl files for other MCL versions.
46;; 08/11/95 bill  load-wood loads big-io-buffer-patch if necessary
47;; 08/10/95 bill  export p-assoc & p-do-btree
48;; 05/31/95 bill  export make-shared-buffer, make-shared-buffer-pool
49;; 05/25/95 bill  add disk-page-hash to *wood-files*
50;; -------------  0.9
51;; 01/17/95 bill  export p-store-pptr, pptr-pointer, pptr-pheap,
52;;                with-transaction, start-transaction, commit-transaction,
53;;                abort-transaction
54;; 11/02/94 ows   export pptr, pheap-pathname
55;; 10/25/94 bill  export pptr-p, p-loaded?, p-stored?,
56;;                wood-disk-resident-slot-names, define-disk-resident-slots
57;; 03/14/94 bill  Don't push anything onto *module-search-path*
58;; -------------- 0.8
59;; 12/27/93 bill  export p-btree-count, p-hash-table-count, initialize-persistent-instance
60;; 12/17/93 bill  Use "wood:wood;..." instead of "wood:..." to prevent
61;;                bogus default directories.
62;;                Add "version-control" to *wood-files*
63;; 03/29/93 bill  Add "q" and "wood-gc" to *wood-files*
64;; -------------- 0.6
65;; 12/16/92 bill  p-btree-clear -> p-clear-btree
66;; 10/21/92 bill  p-nth, p-nthcdr
67;; 08/31/92 bill  export p-make-load-function, p-make-load-function
68;; 08/06/92 bill  (provide "WOOD")
69;; 07/30/92 bill  export p-btree-p and p-hash-table-p
70;; -------------- 0.5
71;; 07/27/92 bill  Export all documented symbols.
72;;
73
74(defpackage :wood
75  #+ppc-target
76  (:import-from "CCL"
77                ccl::databases-locked-p
78                ccl::funcall-with-databases-unlocked
79                ccl::with-databases-unlocked))
80
81(in-package :wood)
82
83(export '(load-wood
84          open-pheap close-pheap with-open-pheap root-object flush-pheap
85          make-shared-buffer make-shared-buffer-pool
86          pheap p-loading-pheap
87          p-load p-store p-stored? p-loaded?
88          p-make-area with-consing-area
89          p-cons p-list p-list-in-area p-make-list
90          p-make-uvector p-make-array p-vector
91          p-listp p-consp p-atom p-uvectorp p-packagep p-symbolp
92          p-stringp p-simple-string-p p-vectorp p-simple-vector-p p-arrayp
93          pload-barrier-p
94          p-car p-cdr p-caar p-cadr p-cdar p-cddr
95          p-caaar p-caadr p-cadar p-caddr p-cdaar p-cdadr p-cddar p-cdddr
96          p-caaaar p-caaadr p-caadar p-caaddr p-cadaar p-cadadr p-caddar p-cadddr
97          p-cdaaar p-cdaadr p-cdadar p-cdaddr p-cddaar p-cddadr p-cdddar p-cddddr
98          p-nth p-nthcdr p-last p-delq p-dolist p-assoc
99          p-instance-class p-slot-value
100          p-uvsize p-uvref p-uvector-subtype-p p-svref p-%svref p-length p-aref
101          p-array-rank p-array-dimensions p-array-dimension
102          p-intern p-find-symbol p-find-package p-make-package
103          p-symbol-name p-symbol-package p-symbol-value
104          p-package-name p-package-nicknames
105          p-make-btree p-btree-p p-btree-lookup p-btree-store p-btree-delete
106          p-clear-btree p-map-btree p-do-btree p-btree-count p-map-btree-keystrings
107          p-make-hash-table p-hash-table-p p-gethash p-remhash p-clrhash
108          p-hash-table-size p-maphash p-hash-table-count
109          wood-slot-names-vector wood-slot-value initialize-persistent-instance
110          p-make-load-function p-make-load-function-object p-make-load-function-using-pheap
111          p-make-load-function-saving-slots progn-load-functions progn-init-functions
112          p-store-pptr
113          p-make-pload-barrier p-load-through-barrier
114          gc-pheap-file clear-memory<->disk-tables
115          with-egc *avoid-cons-caching*
116          pptr-p pptr pptr-pointer pptr-pheap
117          wood-disk-resident-slot-names define-disk-resident-slots
118          pheap-pathname move-pheap-file
119          with-databases-locked with-databases-unlocked databases-locked-p
120          with-transaction start-transaction commit-transaction abort-transaction
121          ))
122
123(setf (logical-pathname-translations "wood")
124      (let ((path (or *load-pathname* *loading-file-source-file*)))
125        (if path
126          (let* ((dest-dir (make-pathname :device    (pathname-device path)
127                                          :host      (pathname-host path)
128                                          :directory (append
129                                                      (or (pathname-directory path)
130                                                          '(:absolute))
131                                                      '(:wild-inferiors))
132                                          :name      :wild
133                                          :type      :wild))
134                 (physical-dir (translate-logical-pathname dest-dir)))
135            ; This is what you'll get if you load this file
136            ; or evaluate this form from this buffer.
137            `(("wood;**;*.*" ,physical-dir)
138              ("**;*.*" ,physical-dir)))
139          ; This is what you'll get if you evalute this form
140          ; from the listener.
141          '(("wood;**;*.*" "ccl:wood;**;*.*")))))
142
143(defun compile-if-needed (file &optional force)
144  (let ((lisp (merge-pathnames file ".lisp"))
145        (fasl (merge-pathnames file ccl::*.fasl-pathname*)))
146    (when (or force
147              (not (probe-file fasl))
148              (> (file-write-date lisp) (file-write-date fasl)))
149      (compile-file lisp :verbose t))))
150
151(defun compile-and-load (file &optional force-compile)
152  (compile-if-needed file force-compile)
153  (handler-case
154    (load file :verbose t)
155    (simple-error (condition)
156      (if (member (simple-condition-format-string condition)
157                  '("Wrong FASL version." "Wrong PFSL version.")
158                  :test 'equalp)
159        (progn
160          (format t "~&;Deleting FASL file from other MCL version...")
161          (delete-file (merge-pathnames file ccl::*.fasl-pathname*))
162          (compile-and-load file force-compile))
163        (error condition)))))
164
165(defparameter *wood-files*
166  '("block-io-mcl" "split-lfun" "q"
167    "disk-page-hash" "disk-cache" "woodequ" "disk-cache-accessors"
168    "disk-cache-inspector" "persistent-heap" "version-control"
169    "btrees" "persistent-clos"
170    "recovery" "wood-gc"))
171
172(defun load-wood (&optional force-compile)
173  (with-compilation-unit ()
174    (compile-if-needed "wood:wood;load-wood")
175    (unless (boundp 'ccl::*elements-per-buffer*)
176      (compile-and-load "wood:patches;big-io-buffer-patch"))
177    (dolist (file *wood-files*)
178      (compile-and-load (merge-pathnames file "wood:wood;") force-compile))
179    #+ppc-target
180    (unless (fboundp 'ccl::databases-locked-p)
181      (compile-and-load "wood:patches;break-loop-patch" force-compile))
182    (provide "WOOD")))
183
184; This should be called only after load-wood.
185; It compiles the changed files
186(defun compile-wood ()
187  (with-compilation-unit ()
188    (compile-if-needed "wood:wood;load-wood")
189    (dolist (file *wood-files*)
190      (compile-if-needed (merge-pathnames file "wood:wood;")))))
191;;;    1   3/10/94  bill         1.8d247
192;;;    2   3/23/94  bill         1.8d277
193;;;    3   7/26/94  Derek        1.9d027
194;;;    4   9/19/94  Cassels      1.9d061
195;;;    5  11/01/94  Derek        1.9d085 Bill's Saving Library Task
196;;;    6  11/05/94  kab          1.9d087
197;;;    7  11/21/94  gsb          1.9d100
198;;;    2   2/18/95  RŽti         1.10d019
199;;;    3   3/23/95  bill         1.11d010
200;;;    4   4/19/95  bill         1.11d021
201;;;    5   6/02/95  bill         1.11d040
Note: See TracBrowser for help on using the repository browser.