Changeset 6


Ignore:
Timestamp:
09/28/07 19:04:51 (9 years ago)
Author:
gz
Message:

Working lispworks version, but now doesn't load in MCL (yet).

Location:
lw-branch
Files:
3 added
13 edited

Legend:

Unmodified
Added
Removed
  • lw-branch/block-io-mcl.lisp

    r2 r6  
    6363(in-package :ccl) 
    6464 
    65 ;; N.B. there is another of this in disk-page-hash.lisp!!! - gone now 
    66 ; Assume fixnum addresses. 
    67 ; Comment out this form to compile Wood for files larger than 256 megs. 
    68 (eval-when (:compile-toplevel :execute :load-toplevel) 
    69   (pushnew :wood-fixnum-addresses *features*)) 
    70  
    71  
    7265(export '(stream-read-bytes stream-write-bytes set-minimum-file-length)) 
    7366 
     
    307300 
    308301) ; end of eval-when 
    309  
    310 (declaim (inline byte-array-p ensure-byte-array)) 
    311  
    312 #-ppc-target 
    313 (defun byte-array-p (array) 
    314   (and (uvectorp array) 
    315        (let ((subtype (%vect-subtype array))) 
    316          (or (eql subtype $v_sstr) 
    317              (eql subtype $v_ubytev) 
    318              (eql subtype $v_sbytev))))) 
    319  
    320 #+ppc-target 
    321 (defun byte-array-p (array) 
    322   (let ((typecode (extract-typecode array))) 
    323     (or (eql typecode ppc::subtag-simple-base-string) 
    324         (eql typecode ppc::subtag-s8-vector) 
    325         (eql typecode ppc::subtag-u8-vector)))) 
    326  
    327 (defun ensure-byte-array (array) 
    328   (unless (byte-array-p array) 
    329     (error "~s is not a byte array" array))) 
    330302 
    331303; Read length bytes into array at offset from stream at address. 
  • lw-branch/btrees.lisp

    r3 r6  
    211211           (simple-string (make-string len :element-type 'base-character))) 
    212212      (declare (dynamic-extent simple-string)) 
    213       (multiple-value-bind (str offset) (ccl::array-data-and-offset string) 
     213      (multiple-value-bind (str offset) (array-data-and-offset string) 
    214214        (wood::%load-string str offset len simple-string)) 
    215215      (funcall thunk simple-string)))) 
     
    358358  (with-databases-locked 
    359359   (with-simple-string (key-string key-string) 
    360      (if (> (length key-string) 127) 
    361        (error "Keys longer than 127 bytes not supported yet.")) 
     360     (when (> (length key-string) 127) 
     361       #-gz(error "Keys longer than 127 bytes not supported yet.") 
     362       #+gz(warn "Keys longer than 127 bytes not supported yet.") 
     363       #+gz (setq key-string (subseq key-string 0 127))) 
    362364     (multiple-value-bind (node offset eq) 
    363365                          (btree-find-leaf-node disk-cache btree key-string) 
     
    674676|# 
    675677 
     678#+GZ 
     679(defun check-used-counts (where disk-cache node) 
     680  (let* ((used (read-unsigned-word disk-cache (+ node $btree_used))) 
     681         (count (read-unsigned-word disk-cache (+ node $btree_count))) 
     682         (bytes (loop for n = 0 then (+ n (normalize-size (+ 5 len) 4)) 
     683                      for i from 0 below count 
     684                      as len = (read-8-bits disk-cache (+ node $btree_data n 4)) 
     685                      finally return n))) 
     686    ;(FORMAT T "~&CHECK-USED-COUNTS@~s node ~s: [count]=~s, [used]=~s, bytes ~s" 
     687    ;        where node count used bytes) 
     688    where 
     689    (assert (<= bytes used)))) 
     690 
     691 
     692 
    676693; New binary search code: Moon's idea. 
    677694(defun %btree-search-node (disk-cache node key-string case-sensitive?) 
     
    680697             (type (simple-array (unsigned-byte 8) (*)) vec)) 
    681698    (accessing-byte-array (vec) 
     699       
    682700      (let* ((count (load.uw (+ $btree_count offset))) 
    683701             (min 0)                    ; inclusive lower bound 
     
    739757                       (return (if (eql i2 end2) 0 -1))) 
    740758                     (when (>= i2 end2) (return 1)) 
    741                      (let ((c1 (ccl::%char-code (char-upcase (ccl::%code-char (aref s1 i1))))) 
    742                            (c2 (ccl::%char-code (char-upcase (ccl::%code-char (aref s2 i2)))))) 
     759                     (let ((c1 (%char-code (char-upcase (%code-char (aref s1 i1))))) 
     760                           (c2 (%char-code (char-upcase (%code-char (aref s2 i2)))))) 
    743761                       (declare (fixnum c1 c2)) 
    744762                       (if (<= c1 c2) 
     
    12861304(defun %shift-node-right (disk-cache btree node free used leaf-p 
    12871305                             offset key-string value value-imm? key-length size) 
    1288   (declare (fixnum free used offset key-length)) 
     1306  (declare (fixnum free used)) 
    12891307  ;(return-from %shift-node-right nil)   ; not yet debugged. 
    12901308  (when (and leaf-p (not (%btree-root-node-p disk-cache node))) 
  • lw-branch/disk-cache-accessors.lisp

    r3 r6  
    66;; low-level accessors for disk-cache's 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    1718;; 
    1819 
     20(eval-when (:execute) 
     21  ;; We lie a lot about the types of arrays.  The compiler is willing 
     22  ;; to trust us, the evaluator might not. 
     23  (warn "This file must be compiled, it probably won't work evaluated.")) 
     24 
    1925;;;;;;;;;;;;;;;;;;;;;;;;;; 
    2026;; 
    2127;; Modification History 
    2228;; 
     29;; 02/01/06 gz   LispWorks port 
    2330;; ------------- 0.961 
    2431;; 09/19/96 bill The PPC version of %%load-pointer handles short floats now via %%load-short-float 
     
    5259;; 
    5360 
    54 (in-package :ccl)                       ; So LAP works easily 
    55  
    56 (export '(wood::read-long wood::read-unsigned-long 
    57           wood::read-string wood::read-pointer 
    58           wood::read-low-24-bits wood::read-8-bits 
    59           wood::fill-long wood::fill-word wood::fill-byte) 
    60         'wood) 
    61  
     61(in-package :wood) 
     62 
     63(export '(read-long read-unsigned-long 
     64          read-string read-pointer 
     65          read-low-24-bits read-8-bits 
     66          fill-long fill-word fill-byte)) 
     67 
     68#+ccl 
    6269(eval-when (:compile-toplevel :execute) 
    6370  #-ppc-target 
     
    105112)  ; end of #+ppc-target progn 
    106113 
    107 (defun wood::read-long (disk-cache address) 
    108   (wood::with-databases-locked 
     114#+LispWorks 
     115(progn 
     116 
     117(defun-inline %%load-long (byte-array address) 
     118  (declare (type (simple-array (unsigned-byte 8) (*)) byte-array) 
     119           (type fixnum address) 
     120           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     121  (sys:int32-to-integer 
     122   (sys:int32-logior 
     123    (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum address)) 24) 
     124                      (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16)) 
     125    (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8) 
     126                      (aref byte-array (the fixnum (+ address 3))))))) 
     127 
     128(defun-inline %%load-unsigned-long (byte-array address) 
     129  (declare (type (simple-array (unsigned-byte 8) (*)) byte-array) 
     130           (type fixnum address) 
     131           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     132  (let* ((b0 (aref byte-array address)) 
     133         (int (sys:int32-to-integer 
     134               (sys:int32-logior 
     135                (sys:int32-logior (sys:int32<< b0 24) 
     136                                  (sys:int32<< (aref byte-array (the fixnum (+ address 1))) 16)) 
     137                (sys:int32-logior (sys:int32<< (aref byte-array (the fixnum (+ address 2))) 8) 
     138                                  (aref byte-array (the fixnum (+ address 3)))))))) 
     139    (declare (type (unsigned-byte 8) b0)) 
     140    (if (logbitp 7 b0) 
     141      (logand #xFFFFFFFF int) 
     142      int))) 
     143) 
     144 
     145(defun read-long (disk-cache address) 
     146  (with-databases-locked 
    109147   (multiple-value-bind (array index count) 
    110                         (wood::get-disk-page disk-cache address) 
     148                        (get-disk-page disk-cache address) 
    111149     (declare (fixnum index count)) 
    112150     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 
    113151       (error "Address odd or past eof: ~s" address)) 
    114      #-ppc-target 
    115      (lap-inline () 
     152     #+ccl-68k-target 
     153     (ccl::lap-inline () 
    116154       (:variable array index) 
    117        (move.l (varg array) atemp0) 
    118        (move.l (varg index) da) 
    119        (getint da) 
    120        (move.l (atemp0 da.l $v_data) arg_z) 
    121        (jsr_subprim $sp-mklong)) 
    122      #+ppc-target 
     155       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     156       (ccl::move.l (ccl::varg index) ccl::da) 
     157       (ccl::getint ccl::da) 
     158       (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 
     159       (ccl::jsr_subprim ccl::$sp-mklong)) 
     160     #-ccl-68k-target 
    123161     (%%load-long array index)))) 
    124162 
     
    132170         (error "Attempt to access outside of buffer bounds"))))) 
    133171 
    134 (defun wood::%load-long (array address) 
     172(defun %load-long (array address) 
    135173  (ensure-byte-array array) 
    136174  (unless (fixnump address) 
     
    140178    (unless (eql 0 (the fixnum (logand 1 address))) 
    141179      (error "Odd address: ~s" address)) 
    142     #-ppc-target 
    143     (lap-inline () 
     180    #+ccl-68k-target 
     181    (ccl::lap-inline () 
    144182      (:variable array address immediate?) 
    145       (move.l (varg array) atemp0) 
    146       (move.l (varg address) da) 
    147       (getint da) 
    148       (move.l (atemp0 da.l $v_data) arg_z) 
    149       (jsr_subprim $sp-mklong)) 
    150     #+ppc-target 
     183      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     184      (ccl::move.l (ccl::varg address) ccl::da) 
     185      (ccl::getint ccl::da) 
     186      (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 
     187      (ccl::jsr_subprim ccl::$sp-mklong)) 
     188    #-ccl-68k-target 
    151189    (%%load-long array address))) 
    152190 
    153 (defun wood::read-unsigned-long (disk-cache address) 
    154   (wood::with-databases-locked 
     191(defun read-unsigned-long (disk-cache address) 
     192  (with-databases-locked 
    155193   (multiple-value-bind (array index count) 
    156                         (wood::get-disk-page disk-cache address) 
     194                        (get-disk-page disk-cache address) 
    157195     (declare (fixnum index count)) 
    158196     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 
    159197       (error "Address odd or past eof: ~s" address)) 
    160      #-ppc-target 
    161      (lap-inline () 
     198     #+ccl-68k-target 
     199     (ccl::lap-inline () 
    162200       (:variable array index) 
    163        (move.l (varg array) atemp0) 
    164        (move.l (varg index) da) 
    165        (getint da) 
    166        (move.l (atemp0 da.l $v_data) arg_z) 
    167        (jsr_subprim $sp-mkulong)) 
    168      #+ppc-target 
     201       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     202       (ccl::move.l (ccl::varg index) ccl::da) 
     203       (ccl::getint ccl::da) 
     204       (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 
     205       (ccl::jsr_subprim ccl::$sp-mkulong)) 
     206     #-ccl-68k-target 
    169207     (%%load-unsigned-long array index)))) 
    170208 
    171 (defun wood::%load-unsigned-long (array address) 
     209(defun %load-unsigned-long (array address) 
    172210  (ensure-byte-array array) 
    173211  (setq address (require-type address 'fixnum)) 
     
    176214    (unless (eql 0 (the fixnum (logand 1 address))) 
    177215      (error "Odd address: ~s" address)) 
    178     #-ppc-target 
    179     (lap-inline () 
     216    #+ccl-68k-target 
     217    (ccl::lap-inline () 
    180218      (:variable array address) 
    181       (move.l (varg array) atemp0) 
    182       (move.l (varg address) da) 
    183       (getint da) 
    184       (move.l (atemp0 da.l $v_data) arg_z) 
    185       (jsr_subprim $sp-mkulong)) 
    186     #+ppc-target 
     219      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     220      (ccl::move.l (ccl::varg address) ccl::da) 
     221      (ccl::getint ccl::da) 
     222      (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 
     223      (ccl::jsr_subprim ccl::$sp-mkulong)) 
     224    #-ccl-68k-target 
    187225    (%%load-unsigned-long array address))) 
    188226 
    189227#+ppc-target 
    190 (progn 
    191  
    192 (declaim (inline %%store-long)) 
    193  
    194 (defun %%store-long (value array address) 
     228(defun-inline %%store-long (value array address) 
    195229  (declare (type (simple-array (unsigned-byte 16) (*)) array) 
    196230           (fixnum address) 
     
    209243  value) 
    210244 
    211 )  ; end of #+ppc-target progn 
    212  
    213 (defun (setf wood::read-long) (value disk-cache address) 
    214   (unless (>= (wood::disk-cache-size disk-cache) 
     245#+LispWorks 
     246(defun %%store-long (value array address) 
     247  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     248           (type fixnum address) 
     249           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     250  (let ((int (sys:integer-to-int32 value))) 
     251    (declare (type sys:int32 int)) 
     252    (setf (aref array (the fixnum address))       (the fixnum (sys:int32-to-integer (sys:int32>> int 24)))) 
     253    (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16)))) 
     254    (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 
     255    (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int))))) 
     256 
     257(defun (setf read-long) (value disk-cache address) 
     258  (unless (>= (disk-cache-size disk-cache) 
    215259              (+ address 4)) 
    216     (wood::extend-disk-cache disk-cache (+ address 4))) 
    217   (wood::with-databases-locked 
     260    (extend-disk-cache disk-cache (+ address 4))) 
     261  (with-databases-locked 
    218262   (multiple-value-bind (array index count) 
    219                         (wood::get-disk-page disk-cache address t) 
     263       (get-disk-page disk-cache address t) 
    220264     (declare (fixnum index count)) 
    221265     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 
    222266       (error "Address odd or past eof: ~s" address)) 
    223      #-ppc-target 
    224      (lap-inline () 
     267    #+ccl-68k-target 
     268    (ccl::lap-inline () 
    225269       (:variable array index value) 
    226        (move.l (varg value) arg_z) 
    227        (jsr_subprim $sp-getxlong) 
    228        (move.l (varg array) atemp0) 
    229        (move.l (varg index) da) 
    230        (getint da) 
    231        (move.l acc (atemp0 da.l $v_data))) 
    232      #+ppc-target 
    233      (%%store-long value array index))) 
     270       (ccl::move.l (ccl::varg value) ccl::arg_z) 
     271       (ccl::jsr_subprim ccl::$sp-getxlong) 
     272       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     273       (ccl::move.l (ccl::varg index) ccl::da) 
     274       (ccl::getint ccl::da) 
     275       (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data))) 
     276    #-ccl-68k-target 
     277    (%%store-long value array index))) 
    234278  value) 
    235279 
    236 (defsetf wood::read-unsigned-long (disk-cache address) (value) 
    237   `(setf (wood::read-long ,disk-cache ,address) ,value)) 
    238  
    239 (defun wood::%store-long (value array address) 
     280(defsetf read-unsigned-long (disk-cache address) (value) 
     281  `(setf (read-long ,disk-cache ,address) ,value)) 
     282 
     283(defun %store-long (value array address) 
    240284  (ensure-byte-array array) 
    241285  (setq address (require-type address 'fixnum)) 
     
    244288    (unless (eql 0 (the fixnum (logand 1 address))) 
    245289      (error "Odd address: ~s" address)) 
    246     #-ppc-target 
    247     (lap-inline () 
     290    #+ccl-68k-target 
     291    (ccl::lap-inline () 
    248292      (:variable array address value) 
    249         (move.l (varg value) arg_z) 
    250         (jsr_subprim $sp-getxlong) 
    251         (move.l (varg array) atemp0) 
    252         (move.l (varg address) da) 
    253         (getint da) 
    254         (move.l acc (atemp0 da.l $v_data))) 
    255     #+ppc-target 
     293        (ccl::move.l (ccl::varg value) ccl::arg_z) 
     294        (ccl::jsr_subprim ccl::$sp-getxlong) 
     295        (ccl::move.l (ccl::varg array) ccl::atemp0) 
     296        (ccl::move.l (ccl::varg address) ccl::da) 
     297        (ccl::getint ccl::da) 
     298        (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data))) 
     299    #-ccl-68k-target 
    256300    (%%store-long value array address)) 
    257301  value) 
    258302 
    259 (defun wood::read-word (disk-cache address) 
    260   (wood::with-databases-locked 
     303#+ppc-target 
     304(progn 
     305 
     306(defun-inline %%load-word (array index) 
     307  (locally (declare (type (simple-array (signed-byte 16)  (*)) array) 
     308                    (optimize (speed 3) (safety 0))) 
     309    (setq index (ash index -1)) 
     310    (aref array index))) 
     311 
     312(defun-inline %%load-unsigned-word (array index) 
     313  (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
     314           (optimize (speed 3) (safety 0))) 
     315  (aref array (the fixnum (ash index -1)))) 
     316 
     317(defun-inline %%store-word (value array index) 
     318  (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
     319                    (type fixnum index) 
     320                    (optimize (speed 3) (safety 0))) 
     321    (setq index (ash index -1)) 
     322    (setf (aref array index) value))) 
     323 
     324) 
     325 
     326 
     327#+LispWorks 
     328(progn 
     329(defun-inline %%load-word (array address) 
     330  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     331           (type fixnum address) 
     332           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     333  (let ((b0 (aref array address))) 
     334    (declare (type (unsigned-byte 8) b0)) 
     335    (the fixnum 
     336         (sys:int32-to-integer 
     337          (sys:int32-logior (sys:int32>> (sys:int32<< b0 24) 16) ;; sign-extend 
     338                            (aref array (the fixnum (1+ address)))))))) 
     339 
     340(defun-inline %%load-unsigned-word (array address) 
     341  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     342           (type fixnum address) 
     343           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     344  (the fixnum 
     345       (sys:int32-to-integer 
     346        (sys:int32-logior (sys:int32<< (aref array address) 8) (aref array (the fixnum (1+ address))))))) 
     347 
     348(defun-inline %%store-word (value array address) 
     349  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     350           (type fixnum address) 
     351           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     352  (let ((int (sys:integer-to-int32 value))) 
     353    (declare (type sys:int32 int)) 
     354    (setf (aref array (the fixnum address))       (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 
     355    (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer int))))) 
     356) 
     357 
     358(defun read-word (disk-cache address) 
     359  (with-databases-locked 
    261360   (multiple-value-bind (array index count) 
    262                         (wood::get-disk-page disk-cache address) 
     361                        (get-disk-page disk-cache address) 
    263362     (declare (fixnum index count)) 
    264363     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 
    265364       (error "Address odd or past eof: ~s" address)) 
    266      #-ppc-target 
    267      (lap-inline () 
     365     #+ccl-68k-target 
     366     (ccl::lap-inline () 
    268367       (:variable array index) 
    269        (move.l (varg array) atemp0) 
    270        (move.l (varg index) da) 
    271        (getint da) 
    272        (move.w (atemp0 da.l $v_data) acc) 
    273        (ext.l acc) 
    274        (mkint acc)) 
    275      #+ppc-target 
    276      (locally (declare (type (simple-array (signed-byte 16)  (*)) array) 
    277                        (optimize (speed 3) (safety 0))) 
    278        (setq index (ash index -1)) 
    279        (aref array index))))) 
    280  
    281 (defun wood::%load-word (array address) 
     368       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     369       (ccl::move.l (ccl::varg index) ccl::da) 
     370       (ccl::getint ccl::da) 
     371       (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 
     372       (ccl::ext.l ccl::acc) 
     373       (ccl::mkint ccl::acc)) 
     374     #-ccl-68k-target 
     375     (%%load-word array index)))) 
     376 
     377(defun %load-word (array address) 
    282378  (ensure-byte-array array) 
    283379  (setq address (require-type address 'fixnum)) 
     
    286382    (unless (eql 0 (the fixnum (logand 1 address))) 
    287383      (error "Odd address: ~s" address)) 
    288     #-ppc-target 
    289     (lap-inline () 
     384    #+ccl-68k-target 
     385    (ccl::lap-inline () 
    290386      (:variable array address) 
    291       (move.l (varg array) atemp0) 
    292       (move.l (varg address) da) 
    293       (getint da) 
    294       (move.w (atemp0 da.l $v_data) acc) 
    295       (ext.l acc) 
    296       (mkint acc)) 
    297     #+ppc-target 
    298     (locally (declare (type (simple-array (signed-byte 16)  (*)) array) 
    299                        (optimize (speed 3) (safety 0))) 
    300        (setq address (ash address -1)) 
    301        (aref array address)))) 
    302  
    303 (defun wood::read-unsigned-word (disk-cache address) 
    304   (wood::with-databases-locked 
     387      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     388      (ccl::move.l (ccl::varg address) ccl::da) 
     389      (ccl::getint ccl::da) 
     390      (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 
     391      (ccl::ext.l ccl::acc) 
     392      (ccl::mkint ccl::acc)) 
     393    #-ccl-68k-target 
     394    (%%load-word array address))) 
     395 
     396(defun read-unsigned-word (disk-cache address) 
     397  (with-databases-locked 
    305398   (multiple-value-bind (array index count) 
    306                         (wood::get-disk-page disk-cache address) 
     399                        (get-disk-page disk-cache address) 
    307400     (declare (fixnum index count)) 
    308401     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 
    309402       (error "Address odd or past eof: ~s" address)) 
    310      #-ppc-target 
    311      (lap-inline () 
     403     #+ccl-68k-target 
     404     (ccl::lap-inline () 
    312405       (:variable array index) 
    313        (move.l (varg array) atemp0) 
    314        (move.l (varg index) da) 
    315        (getint da) 
    316        (move.l ($ 0) acc) 
    317        (move.w (atemp0 da.l $v_data) acc) 
    318        (mkint acc)) 
    319      #+ppc-target 
    320      (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
    321                        (optimize (speed 3) (safety 0))) 
    322        (setq index (ash index -1)) 
    323        (aref array index))))) 
    324  
    325 (defun wood::%load-unsigned-word (array address) 
     406       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     407       (ccl::move.l (ccl::varg index) ccl::da) 
     408       (ccl::getint ccl::da) 
     409       (ccl::move.l (ccl::$ 0) ccl::acc) 
     410       (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 
     411       (ccl::mkint ccl::acc)) 
     412     #-ccl-68k-target 
     413     (%%load-unsigned-word array index)))) 
     414 
     415(defun %load-unsigned-word (array address) 
    326416  (ensure-byte-array array) 
    327417  (setq address (require-type address 'fixnum)) 
     
    330420    (unless (eql 0 (the fixnum (logand 1 address))) 
    331421      (error "Odd address: ~s" address)) 
    332     #-ppc-target 
    333     (lap-inline () 
     422    #+ccl-68k-target 
     423    (ccl::lap-inline () 
    334424      (:variable array address) 
    335       (move.l (varg array) atemp0) 
    336       (move.l (varg address) da) 
    337       (getint da) 
    338       (move.l ($ 0) acc) 
    339       (move.w (atemp0 da.l $v_data) acc) 
    340       (mkint acc)) 
    341     #+ppc-target 
    342     (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
    343                       (optimize (speed 3) (safety 0))) 
    344       (setq address (ash address -1)) 
    345       (aref array address)))) 
    346  
    347 (defun (setf wood::read-word) (value disk-cache address) 
     425      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     426      (ccl::move.l (ccl::varg address) ccl::da) 
     427      (ccl::getint ccl::da) 
     428      (ccl::move.l (ccl::$ 0) ccl::acc) 
     429      (ccl::move.w (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::acc) 
     430      (ccl::mkint ccl::acc)) 
     431    #-ccl-68k-target 
     432    (%%load-unsigned-word array address))) 
     433 
     434(defun (setf read-word) (value disk-cache address) 
    348435  (setq value (require-type value 'fixnum)) 
    349   (unless (>= (wood::disk-cache-size disk-cache) 
     436  (unless (>= (disk-cache-size disk-cache) 
    350437              (+ address 4)) 
    351     (wood::extend-disk-cache disk-cache (+ address 4))) 
    352   (wood::with-databases-locked 
     438    (extend-disk-cache disk-cache (+ address 4))) 
     439  (with-databases-locked 
    353440   (multiple-value-bind (array index count) 
    354                         (wood::get-disk-page disk-cache address t) 
     441                        (get-disk-page disk-cache address t) 
    355442     (declare (fixnum index count)) 
    356443     (unless (and (>= count 2) (eql 0 (the fixnum (logand 1 index)))) 
    357444       (error "Odd address: ~s" address)) 
    358      #-ppc-target 
    359      (lap-inline () 
     445     #+ccl-68k-target 
     446     (ccl::lap-inline () 
    360447       (:variable array index value) 
    361        (move.l (varg value) acc) 
    362        (getint acc) 
    363        (move.l (varg array) atemp0) 
    364        (move.l (varg index) da) 
    365        (getint da) 
    366        (move.w acc (atemp0 da.l $v_data)) 
    367        (mkint acc)) 
    368      #+ppc-target 
    369      (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
    370                        (optimize (speed 3) (safety 0))) 
    371        (setq index (ash index -1)) 
    372        (setf (aref array index) value))))) 
    373  
    374 (defsetf wood::read-unsigned-word (disk-cache address) (value) 
    375   `(setf (wood::read-word ,disk-cache ,address) ,value)) 
    376  
    377 (defun wood::%store-word (value array address) 
     448       (ccl::move.l (ccl::varg value) ccl::acc) 
     449       (ccl::getint ccl::acc) 
     450       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     451       (ccl::move.l (ccl::varg index) ccl::da) 
     452       (ccl::getint ccl::da) 
     453       (ccl::move.w ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)) 
     454       (ccl::mkint ccl::acc)) 
     455     #-ccl-68k-target 
     456     (%%store-word value array index)))) 
     457 
     458(defsetf read-unsigned-word (disk-cache address) (value) 
     459  `(setf (read-word ,disk-cache ,address) ,value)) 
     460 
     461(defun %store-word (value array address) 
    378462  (ensure-byte-array array) 
    379463  (setq address (require-type address 'fixnum)) 
     
    382466    (unless (eql 0 (the fixnum (logand 1 address))) 
    383467      (error "Address not word aligned: ~s" address)) 
    384     #-ppc-target 
    385     (lap-inline () 
     468    #+ccl-68k-target 
     469    (ccl::lap-inline () 
    386470      (:variable value array address) 
    387       (move.l (varg array) atemp0) 
    388       (move.l (varg address) da) 
    389       (getint da) 
    390       (move.l (varg value) acc) 
    391       (getint acc) 
    392       (move.w acc (atemp0 da.l $v_data)) 
    393       (mkint acc)) 
    394     #+ppc-target 
    395     (locally (declare (type (simple-array (unsigned-byte 16)  (*)) array) 
    396                       (optimize (speed 3) (safety 0))) 
    397       (setq address (ash address -1)) 
    398       (setf (aref array address) value)))) 
    399  
    400  
    401 (declaim (inline wood::%%load-pointer wood::%%store-pointer)) 
     471      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     472      (ccl::move.l (ccl::varg address) ccl::da) 
     473      (ccl::getint ccl::da) 
     474      (ccl::move.l (ccl::varg value) ccl::acc) 
     475      (ccl::getint ccl::acc) 
     476      (ccl::move.w ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)) 
     477      (ccl::mkint ccl::acc)) 
     478    #-ccl-68k-target 
     479    (%%store-word value array address))) 
     480 
     481;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    402482 
    403483; same as %load-pointer, but does no type checking 
    404 #-ppc-target 
    405 (defun wood::%%load-pointer (array address) 
     484#+ccl-68k-target 
     485(progn 
     486 
     487(defun-inline %%load-pointer (array address) 
    406488  (let (immediate?) 
    407489    (values 
    408      (lap-inline () 
     490     (ccl::lap-inline () 
    409491       (:variable array address immediate?) 
    410        (move.l (varg array) atemp0) 
    411        (move.l (varg address) da) 
    412        (getint da) 
    413        (move.l (atemp0 da.l $v_data) arg_z) 
    414        (if# (ne (dtagp arg_z $t_fixnum $t_imm $t_sfloat)) 
    415          (movereg arg_z acc) 
    416          (move.l '1 (varg immediate?)) 
    417          else# 
    418          (jsr_subprim $sp-mkulong))) 
     492       (ccl::move.l (ccl::varg array) ccl::atemp0) 
     493       (ccl::move.l (ccl::varg address) ccl::da) 
     494       (ccl::getint ccl::da) 
     495       (ccl::move.l (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::arg_z) 
     496       (ccl::if# (ccl::ne (ccl::dtagp ccl::arg_z ccl::$t_fixnum ccl::$t_imm ccl::$t_sfloat)) 
     497         (ccl::movereg ccl::arg_z ccl::acc) 
     498         (ccl::move.l '1 (ccl::varg immediate?)) 
     499         ccl::else# 
     500         (ccl::jsr_subprim ccl::$sp-mkulong))) 
    419501     immediate?))) 
    420502 
    421503; Same as %store-pointer, but doesn't type check 
    422 #-ppc-target 
    423 (defun wood::%%store-pointer (value array address &optional immediate?) 
    424   (lap-inline () 
     504(defun-inline %%store-pointer (value array address &optional immediate?) 
     505  (ccl::lap-inline () 
    425506    (:variable array address value immediate?) 
    426     (move.l (varg value) arg_z) 
    427     (if# (eq (cmp.l (varg immediate?) nilreg)) 
    428       (jsr_subprim $sp-getxlong)) 
    429     (move.l (varg array) atemp0) 
    430     (move.l (varg address) da) 
    431     (getint da) 
    432     (move.l acc (atemp0 da.l $v_data)))) 
     507    (ccl::move.l (ccl::varg value) ccl::arg_z) 
     508    (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 
     509      (ccl::jsr_subprim ccl::$sp-getxlong)) 
     510    (ccl::move.l (ccl::varg array) ccl::atemp0) 
     511    (ccl::move.l (ccl::varg address) ccl::da) 
     512    (ccl::getint ccl::da) 
     513    (ccl::move.l ccl::acc (ccl::atemp0 ccl::da.l ccl::$v_data)))) 
     514) 
    433515 
    434516#+ppc-target 
     
    436518 
    437519; Load a Wood fixnum returning a lisp fixnum 
    438 (defppclapfunction wood::%%load-fixnum ((array arg_y) (address arg_z)) 
    439   (unbox-fixnum imm0 address) 
    440   (la imm0 ppc::misc-data-offset imm0) 
    441   (lwzx imm0 imm0 array) 
    442   (srawi imm0 imm0 3) 
    443   (box-fixnum arg_z imm0) 
    444   (blr)) 
    445  
    446 (defppclapfunction wood::%%store-fixnum ((value arg_x) (array arg_y) (address arg_z)) 
    447   (unbox-fixnum imm0 address) 
    448   (la imm0 ppc::misc-data-offset imm0) 
    449   (slwi imm1 value (- 3 ppc::fixnum-shift)) 
    450   (stwx imm1 imm0 array) 
    451   (mr arg_z arg_x) 
    452   (blr)) 
     520(ccl::defppclapfunction %%load-fixnum ((array ccl::arg_y) (address ccl::arg_z)) 
     521  (ccl::unbox-fixnum ccl::imm0 address) 
     522  (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 
     523  (ccl::lwzx ccl::imm0 ccl::imm0 array) 
     524  (ccl::srawi ccl::imm0 ccl::imm0 3) 
     525  (ccl::box-fixnum ccl::arg_z ccl::imm0) 
     526  (ccl::blr)) 
     527 
     528(ccl::defppclapfunction %%store-fixnum ((value ccl::arg_x) (array ccl::arg_y) (address ccl::arg_z)) 
     529  (ccl::unbox-fixnum ccl::imm0 address) 
     530  (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 
     531  (ccl::slwi ccl::imm1 value (- 3 ppc::fixnum-shift)) 
     532  (ccl::stwx ccl::imm1 ccl::imm0 array) 
     533  (ccl::mr ccl::arg_z ccl::arg_x) 
     534  (ccl::blr)) 
    453535 
    454536; Load a Wood character returning a lisp character 
    455 (defppclapfunction wood::%%load-character ((array arg_y) (address arg_z)) 
    456   (unbox-fixnum imm0 address) 
    457   (la imm0 ppc::misc-data-offset imm0) 
    458   (lwzx imm0 imm0 array) 
    459   (li arg_z ppc::subtag-character) 
    460   (rlwimi arg_z imm0 0 0 15) 
    461   (blr)) 
    462  
    463 (defppclapfunction wood::%%store-character ((value arg_x) (array arg_y) (address arg_z)) 
    464   (unbox-fixnum imm0 address) 
    465   (la imm0 ppc::misc-data-offset imm0) 
    466   (li imm1 $t_imm_char) 
    467   (rlwimi imm1 value 0 0 15) 
    468   (stwx imm1 imm0 array) 
    469   (mr arg_z arg_x) 
    470   (blr)) 
    471  
    472 (defun wood::%%load-pointer (array address) 
     537(ccl::defppclapfunction %%load-character ((array ccl::arg_y) (address ccl::arg_z)) 
     538  (ccl::unbox-fixnum ccl::imm0 address) 
     539  (ccl::la ccl::imm0 ppc::misc-data-offset ccl::imm0) 
     540  (ccl::lwzx ccl::imm0 ccl::imm0 array) 
     541  (ccl::li ccl::arg_z ppc::subtag-character) 
     542  (ccl::rlwimi ccl::arg_z ccl::imm0 0 0 15) 
     543  (ccl::blr)) 
     544 
     545(ccl::defppclapfunction %%store-character ((value ccl::arg_x) (array ccl::arg_y) (address ccl::arg_z)) 
     546  (ccl::unbox-fixnum ccl::imm0 address) 
     547  (ccl::la imm0 ppc::misc-data-offset ccl::imm0) 
     548  (ccl::li ccl::imm1 ccl::$t_imm_char) 
     549  (ccl::rlwimi ccl::imm1 value 0 0 15) 
     550  (ccl::stwx ccl::imm1 ccl::imm0 array) 
     551  (ccl::mr ccl::arg_z ccl::arg_x) 
     552  (ccl::blr)) 
     553 
     554(defun-inline %%load-pointer (array address) 
    473555  (declare (optimize (speed 3) (safety 0)) 
    474556           (fixnum address)) 
     
    480562    (declare (fixnum tag-byte tag)) 
    481563    (case tag 
    482       (#.wood::$t_fixnum 
    483        (values (wood::%%load-fixnum array address) t)) 
    484       (#.wood::$t_imm 
     564      (#.$t_fixnum 
     565       (values (%%load-fixnum array address) t)) 
     566      (#.$t_imm 
    485567       (values  
    486568        (ecase tag-byte 
    487           (#.$undefined (%unbound-marker-8)) 
    488           (#.$illegal (%illegal-marker)) 
    489           (#.$t_imm_char (wood::%%load-character array address))) 
     569          (#.ccl::$undefined (%unbound-marker)) 
     570          (#.ccl::$illegal (ccl::%illegal-marker)) 
     571          (#.ccl::$t_imm_char (%%load-character array address))) 
    490572        t)) 
    491       (#.wood::$t_sfloat 
    492        (values (wood::%%load-short-float array address) t)) 
     573      (#.$t_sfloat 
     574       (values (%%load-short-float array address) t)) 
    493575      (t (%%load-unsigned-long array address))))) 
    494576 
    495 (defun wood::%%load-short-float (array address) 
     577(defun %%load-short-float (array address) 
    496578  (declare (fixnum address) 
    497579           (type (simple-array (unsigned-byte 8) (*)) array) 
     
    531613    res)) 
    532614 
    533 (defun wood::%%store-pointer (value array address &optional imm?) 
     615(defun-inline %%store-pointer (value array address &optional imm?) 
    534616  (cond ((not imm?) 
    535617         (%%store-long value array address)) 
    536         ((fixnump value) (wood::%%store-fixnum value array address)) 
    537         ((characterp value) (wood::%%store-character value array address)) 
    538         ((eq value (%unbound-marker-8)) 
    539          (%%store-long $undefined array address)) 
    540         ((eq value (%illegal-marker)) 
    541          (%%store-long $illegal array address)) 
     618        ((fixnump value) (%%store-fixnum value array address)) 
     619        ((characterp value) (%%store-character value array address)) 
     620        ((eq value (%unbound-marker)) 
     621         (%%store-long ccl::$undefined array address)) 
     622        ((eq value (ccl::%illegal-marker)) 
     623         (%%store-long ccl::$illegal array address)) 
    542624        (t (error "~s is not a valid immediate" value))) 
    543625  value) 
     
    545627)  ; end of #+ppc-target progn 
    546628 
     629#+LispWorks 
     630(progn 
     631 
     632(defun-inline %%store-tagged (value tag array address) 
     633  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     634           (type fixnum value address tag) 
     635           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     636  (let ((int (sys:integer-to-int32 value))) 
     637    (declare (type sys:int32 int)) 
     638    (setf (aref array (the fixnum address))       (the fixnum (sys:int32-to-integer (sys:int32>> int 21)))) 
     639    (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 13)))) 
     640    (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 5)))) 
     641    (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer 
     642                                                               (sys:int32-logior (sys:integer-to-int32 tag) 
     643                                                                                 (sys:int32<< int 3))))))) 
     644(defun-inline %%load-tagged (array address) 
     645  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     646           (type fixnum address) 
     647           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     648  (let ((b3 (aref array (the fixnum (+ address 3))))) 
     649    (declare (type (unsigned-byte 8) b3)) 
     650    (values 
     651     (the fixnum 
     652          (sys:int32-to-integer 
     653           (sys:int32-logior 
     654            (sys:int32-logior (sys:int32<< (aref array (the fixnum address)) 21) 
     655                              (sys:int32<< (aref array (the fixnum (+ address 1))) 13)) 
     656            (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 5) 
     657                              (sys:int32>> b3 3))))) 
     658     (pointer-tag b3)))) 
     659 
     660(defun-inline %%load-pointer (array address) 
     661  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     662  (multiple-value-bind (value tag) (%%load-tagged array address) 
     663    (declare (type fixnum value tag)) 
     664    (case tag 
     665      (#.$t_pos_fixnum (values value t)) 
     666      (#.$t_neg_fixnum (values (the fixnum (+ most-negative-fixnum value)) t)) 
     667      (#.$t_char (values (code-char value) t)) 
     668      (#.$t_imm (values (ecase value 
     669                          (#.$undefined-imm (%unbound-marker))) t)) 
     670      (t (%%load-unsigned-long array address))))) 
     671 
     672(defun-inline %%store-pointer (value array address &optional imm?) 
     673  (cond ((not imm?) (%%store-long value array address)) 
     674        ((fixnump value) (if (>= (the fixnum value) 0) 
     675                           (%%store-tagged value $t_pos_fixnum array address) 
     676                           (%%store-tagged value $t_neg_fixnum array address))) 
     677        ((characterp value) (%%store-tagged (char-code value) $t_char array address)) 
     678        ;; Do we even need tnis? 
     679        ((eq value (%unbound-marker)) (%%store-tagged $undefined-imm $t_imm array address)) 
     680        (t (error "~s is an unknown immediate type" value)))) 
     681 
     682) ; end of #+LispWorks progn 
     683 
    547684; Avoid consing bignums by not boxing immediate data from the file. 
    548685; Second value is true if the result was immediate. 
    549 (defun wood::read-pointer (disk-cache address) 
    550   (wood::with-databases-locked 
     686(defun read-pointer (disk-cache address #+LispWorks &optional #+LispWorks ignore) 
     687  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
     688  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     689  (with-databases-locked 
    551690   (multiple-value-bind (array index count) 
    552                         (wood::get-disk-page disk-cache address) 
     691                        (get-disk-page disk-cache address) 
    553692     (declare (fixnum index count)) 
    554693     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 
    555694       (error "Address odd or past eof: ~s" address)) 
    556      (wood::%%load-pointer array index)))) 
     695     (%%load-pointer array index)))) 
    557696 
    558697; load directly from a byte array. 
    559 (defun wood::%load-pointer (array address) 
     698(defun %load-pointer (array address) 
    560699  (ensure-byte-array array) 
    561700  (setq address (require-type address 'fixnum)) 
     
    564703    (unless (eql 0 (the fixnum (logand 1 address))) 
    565704      (error "Odd address: ~s" address)) 
    566     (wood::%%load-pointer array address))) 
    567  
    568 (defun (setf wood::read-pointer) (value disk-cache address &optional immediate?) 
    569   (unless (>= (wood::disk-cache-size disk-cache) 
     705    (%%load-pointer array address))) 
     706 
     707(defun (setf read-pointer) (value disk-cache address &optional immediate?) 
     708  (unless (>= (disk-cache-size disk-cache) 
    570709              (+ address 4)) 
    571     (wood::extend-disk-cache disk-cache (+ address 4))) 
    572   (wood::with-databases-locked 
     710    (extend-disk-cache disk-cache (+ address 4))) 
     711  (with-databases-locked 
    573712   (multiple-value-bind (array index count) 
    574                         (wood::get-disk-page disk-cache address t) 
     713                        (get-disk-page disk-cache address t) 
    575714     (declare (fixnum index count)) 
    576715     (unless (and (>= count 4) (eql 0 (the fixnum (logand 1 index)))) 
    577716       (error "Address odd or past eof: ~s" address)) 
    578      (wood::%%store-pointer value array index immediate?))) 
     717     (%%store-pointer value array index immediate?))) 
    579718  value) 
    580719 
    581 (defun wood::%store-pointer (value array address &optional immediate?) 
     720(defun %store-pointer (value array address &optional immediate?) 
    582721  (ensure-byte-array array) 
    583722  (setq address (require-type address 'fixnum)) 
     
    586725    (unless (eql 0 (the fixnum (logand 1 address))) 
    587726      (error "Odd address: ~s" address)) 
    588     (wood::%%store-pointer value array address immediate?)) 
     727    (%%store-pointer value array address immediate?)) 
    589728  value) 
    590729 
    591 (declaim (inline wood::%%load-low-24-bits %%store-low-24-bits)) 
    592  
    593 (defun wood::%%load-low-24-bits (array index) 
     730#+ccl (progn 
     731(declaim (inline %%load-low-24-bits %%store-low-24-bits)) 
     732 
     733(defun %%load-low-24-bits (array index) 
    594734  (declare (optimize (speed 3) (safety 0)) 
    595735           (fixnum index)) 
     
    605745      (+ (the fixnum (ash high-word 16)) low-word)))) 
    606746 
    607 (defun wood::%%store-low-24-bits (value array index) 
     747(defun %%store-low-24-bits (value array index) 
    608748  (declare (optimize (speed 3) (safety 0)) 
    609749           (fixnum value index)) 
     
    617757      (setf (aref array (the fixnum (1+ index))) high-word))) 
    618758  value) 
    619  
    620 (defun wood::read-low-24-bits (disk-cache address) 
    621   (wood::with-databases-locked 
     759) ;#+ccl 
     760 
     761#+LispWorks (progn 
     762(defun-inline %%load-low-24-bits (array address) 
     763  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     764           (type fixnum address) 
     765           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     766  (sys:int32-to-integer 
     767   (sys:int32-logior 
     768    (sys:int32<< (aref array (the fixnum (+ address 1))) 16) 
     769    (sys:int32-logior (sys:int32<< (aref array (the fixnum (+ address 2))) 8) 
     770                      (aref array (the fixnum (+ address 3))))))) 
     771 
     772(defun-inline %%store-low-24-bits (value array address) 
     773  (declare (type (simple-array (unsigned-byte 8) (*)) array) 
     774           (type fixnum address) 
     775           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     776  (let ((int (sys:integer-to-int32 value))) 
     777    (declare (type sys:int32 int)) 
     778    (setf (aref array (the fixnum (+ address 1))) (the fixnum (sys:int32-to-integer (sys:int32>> int 16)))) 
     779    (setf (aref array (the fixnum (+ address 2))) (the fixnum (sys:int32-to-integer (sys:int32>> int 8)))) 
     780    (setf (aref array (the fixnum (+ address 3))) (the fixnum (sys:int32-to-integer int))))) 
     781) ;#+LispWorks 
     782 
     783(defun read-low-24-bits (disk-cache address) 
     784  (with-databases-locked 
    622785   (multiple-value-bind (array index count) 
    623                         (wood::get-disk-page disk-cache address) 
     786                        (get-disk-page disk-cache address) 
    624787     (declare (fixnum index count)) 
    625788     (unless (>= count 4) 
    626789       (error "Address past eof or not longword aligned: ~s" address)) 
    627      (wood::%%load-low-24-bits array index)))) 
    628  
    629 (defun (setf wood::read-low-24-bits) (value disk-cache address) 
     790     (%%load-low-24-bits array index)))) 
     791 
     792(defun (setf read-low-24-bits) (value disk-cache address) 
    630793  (unless (fixnump value) 
    631794    (setq value (require-type value 'fixnum))) 
    632   (unless (>= (wood::disk-cache-size disk-cache) 
     795  (unless (>= (disk-cache-size disk-cache) 
    633796              (+ address 4)) 
    634     (wood::extend-disk-cache disk-cache (+ address 4))) 
    635   (wood::with-databases-locked 
     797    (extend-disk-cache disk-cache (+ address 4))) 
     798  (with-databases-locked 
    636799   (multiple-value-bind (array index count) 
    637                         (wood::get-disk-page disk-cache address t) 
     800                        (get-disk-page disk-cache address t) 
    638801     (declare (fixnum index count)) 
    639802     (unless (>= count 4) 
    640803       (error "Address not longword aligned: ~s" address)) 
    641      (wood::%%store-low-24-bits value array index))) 
     804     (%%store-low-24-bits value array index))) 
    642805  value) 
    643806 
    644807; Read an unsigned byte. Can't call it read-byte as Common Lisp 
    645808; already exports that symbol 
    646 (defun wood::read-8-bits (disk-cache address) 
    647   (wood::with-databases-locked 
     809(defun read-8-bits (disk-cache address) 
     810  (with-databases-locked 
    648811   (multiple-value-bind (array index count) 
    649                         (wood::get-disk-page disk-cache address) 
     812                        (get-disk-page disk-cache address) 
    650813     (declare (fixnum index count) 
    651814              (type (simple-array (unsigned-byte 8) (*)) array) 
     
    655818     (aref array index)))) 
    656819 
    657 (defun wood::read-8-bits-signed (disk-cache address) 
    658   (wood::with-databases-locked 
     820(defun read-8-bits-signed (disk-cache address) 
     821  (with-databases-locked 
    659822   (multiple-value-bind (array index count) 
    660                         (wood::get-disk-page disk-cache address) 
     823                        (get-disk-page disk-cache address) 
    661824     (declare (fixnum index count) 
    662               (type (simple-array (signed-byte 8) (*)) array) 
     825              (type (simple-array (signed-byte 8) (*)) array) ;lie 
    663826              (optimize (speed 3) (safety 0))) 
    664827     (unless (>= count 1) 
     
    666829     (aref array index)))) 
    667830 
    668 (defun wood::%load-8-bits (array address) 
     831(defun %load-8-bits (array address) 
    669832  (ensure-byte-array array) 
    670833  (setq address (require-type address 'fixnum)) 
     
    675838    (aref array address))) 
    676839 
    677 (defun (setf wood::read-8-bits) (value disk-cache address) 
    678   (unless (>= (wood::disk-cache-size disk-cache) 
     840(defun (setf read-8-bits) (value disk-cache address) 
     841  (unless (>= (disk-cache-size disk-cache) 
    679842              (+ address 4)) 
    680     (wood::extend-disk-cache disk-cache (+ address 4))) 
    681   (wood::with-databases-locked 
     843    (extend-disk-cache disk-cache (+ address 4))) 
     844  (with-databases-locked 
    682845   (multiple-value-bind (array index count) 
    683                         (wood::get-disk-page disk-cache address t) 
     846                        (get-disk-page disk-cache address t) 
    684847     (declare (fixnum index count) 
    685848              (type (simple-array (unsigned-byte 8) (*)) array) 
     
    689852     (setf (aref array index) value)))) 
    690853 
    691 (defsetf wood::read-8-bits-signed (disk-cache address) (value) 
    692   `(setf (wood::read-8-bits ,disk-cache ,address) ,value)) 
    693  
    694 (defun wood::%store-8-bits (value array address) 
     854(defsetf read-8-bits-signed (disk-cache address) (value) 
     855  `(setf (read-8-bits ,disk-cache ,address) ,value)) 
     856 
     857(defun %store-8-bits (value array address) 
    695858  (ensure-byte-array array) 
    696859  (setq address (require-type address 'fixnum)) 
     
    702865 
    703866; These will get less ugly when we can stack cons float vectors 
    704 #-ppc-target 
    705 (defun wood::read-double-float (disk-cache address) 
     867#+ccl-68k-target (progn 
     868(defun read-double-float (disk-cache address) 
    706869  (let ((vector (make-array 2 :element-type '(signed-byte 32)))) 
    707870    (declare (dynamic-extent vector)) 
    708     (wood::load-byte-array disk-cache address 8 vector 0 t) 
     871    (load-bytes-to-ivector disk-cache address 8 vector) 
    709872    (ccl::%typed-uvref ccl::$v_floatv vector 0))) 
    710873 
    711 #+ppc-target 
    712 (defun wood::read-double-float (disk-cache address) 
    713   (let ((float (%copy-float 0.0))) 
    714     (wood::load-byte-array disk-cache address 8 float 4 t) 
    715     float)) 
    716  
    717 #-ppc-target 
    718 (defun (setf wood::read-double-float) (value disk-cache address) 
     874(defun (setf read-double-float) (value disk-cache address) 
    719875  (let ((vector (make-array 2 :element-type '(signed-byte 32)))) 
    720876    (declare (dynamic-extent vector)) 
    721877    (ccl::%typed-uvset ccl::$v_floatv vector 0 value) 
    722     (wood::store-byte-array vector disk-cache address 8 0 t)) 
     878    (store-bytes-as-byte-vector vector disk-cache address 8 0)) 
    723879  value) 
    724  
    725 #+ppc-target 
    726 (defun (setf wood::read-double-float) (value disk-cache address) 
     880) ; #+ccl-68k-target 
     881 
     882#+ppc-target (progn 
     883(defun (setf read-double-float) (value disk-cache address) 
    727884  (unless (typep value 'double-float) 
    728885    (setq value (require-type value 'double-float))) 
    729   (wood::store-byte-array value disk-cache address 8 4 t) 
     886  (store-bytes-as-byte-vector value disk-cache address 8 4) 
    730887  value) 
    731888 
    732 (defun wood::read-string (disk-cache address length &optional string) 
     889(defun read-double-float (disk-cache address) 
     890  (let ((float (ccl::%copy-float 0.0))) 
     891    (load-bytes-as-byte-vector disk-cache address 8 float 4) ;; lie 
     892    float)) 
     893) ; #+ppc-target 
     894 
     895#+LispWorks 
     896(progn 
     897 
     898(defparameter *unknown-float* (make-array 1 :element-type 'double-float :initial-element 7.7d70)) 
     899 
     900(defun make-a-float () 
     901  (declare (optimize (safety 0) (speed 3) #+LispWorks (float 0))) 
     902  ;; This has to box the float, so we get a new float object. 
     903  (aref (the (simple-array double-float (*)) *unknown-float*) 0)) 
     904 
     905(defun read-double-float (disk-cache address) 
     906  (declare (optimize (speed 3) (safety 0) (debug 0))) 
     907  (let ((float (make-a-float))) 
     908    (load-bytes-as-byte-vector disk-cache address 8 float $float-read-offset) 
     909    float)) 
     910 
     911(defun (setf read-double-float) (value disk-cache address) 
     912  (declare (optimize (speed 3) (safety 0) (debug 0))) 
     913  (store-bytes-as-byte-vector value disk-cache address 8 $float-read-offset) 
     914  value) 
     915) ; #+LispWorks 
     916 
     917(defun read-string (disk-cache address length &optional string) 
    733918  (setq length (require-type length 'fixnum)) 
    734919  (locally (declare (fixnum length)) 
    735     (when (> (+ address length) (wood::disk-cache-size disk-cache)) 
     920    (when (> (+ address length) (disk-cache-size disk-cache)) 
    736921      (error "Attempt to read past EOF")) 
    737922    (let ((offset 0) 
     
    755940                     (setq string (make-string length :element-type 'base-character))))) 
    756941      (loop 
    757         (wood::with-databases-locked 
     942        (with-databases-locked 
    758943         (multiple-value-bind (array index count) 
    759                               (wood::get-disk-page disk-cache address) 
     944                              (get-disk-page disk-cache address) 
    760945           (declare (fixnum count index)) 
    761            #-ppc-target 
    762            (lap-inline () 
     946           #+ccl-68k-target 
     947           (ccl::lap-inline () 
    763948             (:variable array index count length inner-string offset) 
    764              (move.l (varg array) atemp0) 
    765              (move.l (varg index) da) 
    766              (getint da) 
    767              (lea (atemp0 da.l $v_data) atemp0) 
    768              (move.l (varg inner-string) atemp1) 
    769              (move.l (varg offset) da) 
    770              (getint da) 
    771              (lea (atemp1 da.l $v_data) atemp1) 
    772              (move.l (varg length) da) 
    773              (if# (gt (cmp.l (varg count) da)) 
    774                (move.l (varg count) da)) 
    775              (getint da) 
    776              (dbfloop.l da 
    777                      (move.b atemp0@+ atemp1@+))) 
    778            #+ppc-target 
    779            (%copy-ivector-to-ivector 
     949             (ccl::move.l (ccl::varg array) ccl::atemp0) 
     950             (ccl::move.l (ccl::varg index) ccl::da) 
     951             (ccl::getint ccl::da) 
     952             (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     953             (ccl::move.l (ccl::varg inner-string) ccl::atemp1) 
     954             (ccl::move.l (ccl::varg offset) ccl::da) 
     955             (ccl::getint ccl::da) 
     956             (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 
     957             (ccl::move.l (ccl::varg length) ccl::da) 
     958             (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 
     959               (ccl::move.l (ccl::varg count) ccl::da)) 
     960             (ccl::getint ccl::da) 
     961             (ccl::dbfloop.l ccl::da 
     962                     (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))) 
     963           #-ccl-68k-target 
     964           (copy-as-byte-vector 
    780965            array index inner-string offset 
    781966            (if (< count length) count length)) 
    782967           (when (<= (decf length count) 0) 
    783968             (return)) 
    784            (incf address (the fixnum (+ count wood::$block-overhead))) 
     969           (incf address (the fixnum (+ count $block-overhead))) 
    785970           (incf offset count)))))) 
    786971  string) 
     
    789974; non-array uvectors. 
    790975(defun lenient-array-data-and-offset (array) 
    791   (if #-ppc-target (eql $v_arrayh (%vect-subtype array)) 
     976  (if #+ccl-68k-target (eql $v_arrayh (%vect-subtype array)) 
    792977      #+ppc-target (let ((typecode (ppc-typecode array))) 
    793978                     (declare (fixnum typecode)) 
    794979                     (or (eql typecode ppc::subtag-arrayh) 
    795980                         (eql typecode ppc::subtag-vectorh))) 
     981      #-ccl (arrayp array) 
    796982    (array-data-and-offset array) 
    797983    (values array 0))) 
    798984 
    799 #-ppc-target 
     985#+ccl-68k-target 
    800986(defun uvector-bytes (uvector) 
    801   (lap-inline (uvector) 
    802     (if# (eq (dtagp arg_z $t_vector)) 
    803       (wtaerr arg_z 'uvector)) 
    804     (move.l arg_z atemp0) 
    805     (vsize atemp0 arg_z) 
    806     (mkint arg_z))) 
     987  (ccl::lap-inline (uvector) 
     988    (ccl::if# (ccl::eq (ccl::dtagp ccl::arg_z ccl::$t_vector)) 
     989      (ccl::wtaerr ccl::arg_z 'ccl::uvector)) 
     990    (ccl::move.l ccl::arg_z ccl::atemp0) 
     991    (ccl::vsize ccl::atemp0 ccl::arg_z) 
     992    (ccl::mkint ccl::arg_z))) 
    807993 
    808994#+ppc-target 
     
    8161002       (ash length 2)))) 
    8171003 
    818 (defun wood::load-byte-array (disk-cache address length byte-array &optional 
    819                                          (start 0) trust-me?) 
     1004(defun-inline load-bytes-to-string (disk-cache address length string) 
     1005  (ensure-byte-array string) 
     1006  (if (> length (byte-vector-length string)) 
     1007    (error "(~s ~s) < ~s" 'byte-vector-length string length)) 
     1008  (load-bytes-to-ivector disk-cache address length string)) 
     1009 
     1010(defun-inline load-bytes-to-bit-vector (disk-cache address num-bytes bitvector) 
     1011  (assert (typep bitvector '(simple-array (unsigned-byte 1) (*)))) 
     1012  (load-bytes-to-ivector disk-cache address num-bytes bitvector)) 
     1013 
     1014(defun load-bytes-to-ivector (disk-cache address length ivector) 
     1015  (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*)) 
     1016  (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector) 
     1017    (let* ((subtype (uvector-subtype ivector)) 
     1018           (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype)) 
     1019                           #+LispWorks (svref *subtype->array-byte-offset* subtype)))) 
     1020      (load-bytes-as-byte-vector disk-cache address length inner-array byte-offset))) 
     1021  ivector) 
     1022 
     1023#+LispWorks 
     1024(defun load-bytes-to-iarray (disk-cache address num-bytes array) 
     1025  ;; Array is a non-displaced array of immediate data.  I won't even begin to guess at the 
     1026  ;; internal format. 
     1027  (let* ((num-elts (array-total-size array)) 
     1028         (ivector (make-array num-elts :element-type (array-element-type array)))) 
     1029    (load-bytes-to-ivector disk-cache address num-bytes ivector) 
     1030    (loop for i from 0 below num-elts 
     1031          do (setf (row-major-aref array i) (aref ivector i))) 
     1032    array)) 
     1033 
     1034(defun load-bytes-as-byte-vector (disk-cache address length ivector byte-offset) 
    8201035  (setq length (require-type length 'fixnum)) 
    821   (setq start (require-type start 'fixnum)) 
    822   (locally (declare (fixnum length)) 
    823     (when (> (+ address length) (wood::disk-cache-size disk-cache)) 
     1036  (setq byte-offset (require-type byte-offset 'fixnum)) 
     1037  (setq ivector (require-type ivector 'simple-array)) 
     1038  (locally (declare (fixnum length byte-offset)) 
     1039    (when (> (+ address length) (disk-cache-size disk-cache)) 
    8241040      (error "Attempt to read past EOF")) 
    825     (multiple-value-bind (inner-array offset) 
    826                          (lenient-array-data-and-offset byte-array) 
    827       (unless trust-me?                 ; for p-load-ivector 
    828         (ensure-byte-array byte-array) 
    829         (if (> (+ start length) (uvector-bytes byte-array)) 
    830           (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length)))) 
    831       (incf offset start) 
    832       (loop 
    833         (wood::with-databases-locked 
    834          (multiple-value-bind (array index count) 
    835                               (wood::get-disk-page disk-cache address) 
    836            (declare (fixnum count index)) 
    837            #-ppc-target 
    838            (lap-inline () 
    839              (:variable array index count length inner-array offset) 
    840              (move.l (varg array) atemp0) 
    841              (move.l (varg index) da) 
    842              (getint da) 
    843              (lea (atemp0 da.l $v_data) atemp0) 
    844              (move.l (varg inner-array) atemp1) 
    845              (move.l (varg offset) da) 
    846              (getint da) 
    847              (lea (atemp1 da.l $v_data) atemp1) 
    848              (move.l (varg length) da) 
    849              (if# (gt (cmp.l (varg count) da)) 
    850                (move.l (varg count) da)) 
    851              (getint da) 
    852              (dbfloop.l da 
    853                      (move.b atemp0@+ atemp1@+))) 
    854            #+ppc-target 
    855            (%copy-ivector-to-ivector 
    856             array index inner-array offset 
    857             (if (< count length) count length)) 
    858            (when (<= (decf length count) 0) 
    859              (return)) 
    860            (incf address (the fixnum (+ count wood::$block-overhead))) 
    861            (incf offset count)))))) 
    862   byte-array) 
     1041    (loop 
     1042      (with-databases-locked 
     1043       (multiple-value-bind (array index count) 
     1044                            (get-disk-page disk-cache address) 
     1045         (declare (fixnum count index)) 
     1046         #+ccl-68k-target 
     1047         (ccl::lap-inline () 
     1048           (:variable array index count length ivector byte-offset) 
     1049           (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1050           (ccl::move.l (ccl::varg index) ccl::da) 
     1051           (ccl::getint ccl::da) 
     1052           (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1053           (ccl::move.l (ccl::varg ivector) ccl::atemp1) 
     1054           (ccl::move.l (ccl::varg byte-offset) ccl::da) 
     1055           (ccl::getint ccl::da) 
     1056           (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 
     1057           (ccl::move.l (ccl::varg length) ccl::da) 
     1058           (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 
     1059             (ccl::move.l (ccl::varg count) ccl::da)) 
     1060           (ccl::getint ccl::da) 
     1061           (ccl::dbfloop.l ccl::da 
     1062                   (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))) 
     1063         #-ccl-68k-target 
     1064         (copy-as-byte-vector array index ivector byte-offset 
     1065                              (if (< count length) count length)) 
     1066         (when (<= (decf length count) 0) 
     1067           (return)) 
     1068         (incf address (the fixnum (+ count $block-overhead))) 
     1069         (incf byte-offset count)))))) 
     1070 
    8631071 
    8641072; Copy length bytes from from at from-index to to at to-index. 
     
    8671075; If either array is not a byte array or string, you will likely crash 
    8681076; sometime in the future. 
    869 (defun wood::%copy-byte-array-portion (from from-index length to to-index &optional to-page) 
     1077(defun %copy-byte-array-portion (from from-index length to to-index &optional to-page) 
    8701078  (declare (ignore to-page))            ; for logging/recovery 
    8711079  (setq from-index (require-type from-index 'fixnum)) 
     
    8751083    (when (> length 0) 
    8761084      (unless (and (>= from-index 0) 
    877                    (<= (the fixnum (+ from-index length)) (uvector-bytes from)) 
     1085                   (<= (the fixnum (+ from-index length)) (byte-vector-length from)) 
    8781086                   (>= to-index 0) 
    879                    (<= (the fixnum (+ to-index length)) (uvector-bytes to))) 
     1087                   (<= (the fixnum (+ to-index length)) (byte-vector-length to))) 
    8801088        (error "Attempt to index off end of one of the arrays")) 
    8811089      (multiple-value-bind (from off) (lenient-array-data-and-offset from) 
     
    8851093          (ensure-byte-array from) 
    8861094          (ensure-byte-array to) 
    887           #-ppc-target 
    888           (lap-inline () 
     1095          #+ccl-68k-target 
     1096          (ccl::lap-inline () 
    8891097            (:variable from from-index length to to-index) 
    890             (move.l (varg from) atemp0) 
    891             (move.l atemp0 arg_x)             ; arg_x = from 
    892             (move.l (varg from-index) da) 
    893             (getint da) 
    894             (move.l da arg_y)                 ; arg_y = from-index 
    895             (lea (atemp0 da.l $v_data) atemp0) 
    896             (move.l (varg to) atemp1) 
    897             (move.l atemp1 arg_z)             ; arg_z = to 
    898             (move.l (varg to-index) da) 
    899             (getint da) 
    900             (move.l da db)                    ; db = to-index 
    901             (lea (atemp1 da.l $v_data) atemp1) 
    902             (move.l (varg length) da) 
    903             (getint da) 
     1098            (ccl::move.l (ccl::varg from) ccl::atemp0) 
     1099            (ccl::move.l ccl::atemp0 ccl::arg_x)             ; arg_x = from 
     1100            (ccl::move.l (ccl::varg from-index) ccl::da) 
     1101            (ccl::getint ccl::da) 
     1102            (ccl::move.l ccl::da ccl::arg_y)                 ; arg_y = from-index 
     1103            (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1104            (ccl::move.l (ccl::varg to) ccl::atemp1) 
     1105            (ccl::move.l ccl::atemp1 ccl::arg_z)             ; arg_z = to 
     1106            (ccl::move.l (ccl::varg to-index) ccl::da) 
     1107            (ccl::getint ccl::da) 
     1108            (ccl::move.l ccl::da ccl::db)                    ; db = to-index 
     1109            (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 
     1110            (ccl::move.l (ccl::varg length) ccl::da) 
     1111            (ccl::getint ccl::da) 
    9041112            ; _BlockMove is slower for small moves 
    905             (if# (gt (cmp.l ($ 128) da)) 
    906               (move.l da acc) 
    907               (dc.w #_BlockMove) 
    908               else# 
    909               (if# (and (eq (cmp.l arg_x arg_z)) 
    910                         (gt (cmp.l arg_y db))) 
    911                 (add.l da atemp0) 
    912                 (add.l da atemp1) 
    913                 (dbfloop.l da 
    914                         (move.b -@atemp0 -@atemp1)) 
    915                 else# 
    916                 (dbfloop.l da 
    917                         (move.b atemp0@+ atemp1@+))))) 
    918           #+ppc-target 
    919           (%copy-ivector-to-ivector 
     1113            (ccl::if# (ccl::gt (ccl::cmp.l (ccl::$ 128) ccl::da)) 
     1114              (ccl::move.l ccl::da ccl::acc) 
     1115              (ccl::dc.w #_BlockMove) 
     1116              ccl::else# 
     1117              (ccl::if# (and (ccl::eq (ccl::cmp.l ccl::arg_x ccl::arg_z)) 
     1118                             (ccl::gt (ccl::cmp.l ccl::arg_y ccl::db))) 
     1119                (ccl::add.l ccl::da ccl::atemp0) 
     1120                (ccl::add.l da ccl::atemp1) 
     1121                (ccl::dbfloop.l ccl::da 
     1122                        (ccl::move.b ccl::-@atemp0 ccl::-@atemp1)) 
     1123                ccl::else# 
     1124                (ccl::dbfloop.l ccl::da 
     1125                        (ccl::move.b ccl::atemp0@+ ccl::atemp1@+))))) 
     1126          #-ccl-68k-target 
     1127          (copy-as-byte-vector 
    9201128           from from-index to to-index length))))) 
    9211129  to) 
    9221130 
    923 (defun wood::%load-string (array index length &optional string) 
     1131(defun %load-string (array index length &optional string) 
    9241132  (unless string 
    9251133    (setq string (make-string length :element-type 'base-character))) 
    926   (wood::%copy-byte-array-portion array index length string 0)) 
    927  
    928 (defun wood::%store-string (string array index &optional (length (length string))) 
    929   (wood::%copy-byte-array-portion string 0 length array index) 
     1134  (%copy-byte-array-portion array index length string 0)) 
     1135 
     1136(defun %store-string (string array index &optional (length (length string))) 
     1137  (%copy-byte-array-portion string 0 length array index) 
    9301138  string) 
    9311139   
    932 (defun (setf wood::read-string) (string disk-cache address &optional length) 
     1140(defun (setf read-string) (string disk-cache address &optional length) 
    9331141  (if length 
    9341142    (when (> (setq length (require-type length 'fixnum)) (length string)) 
    9351143      (error "~s > the length of the string." 'length)) 
    9361144    (setq length (length string))) 
    937   (unless (>= (wood::disk-cache-size disk-cache) 
     1145  (unless (>= (disk-cache-size disk-cache) 
    9381146              (+ address length)) 
    939     (wood::extend-disk-cache disk-cache (+ address length))) 
     1147    (extend-disk-cache disk-cache (+ address length))) 
    9401148  (multiple-value-bind (string offset) (array-data-and-offset string) 
    9411149    (declare (fixnum offset)) 
    9421150    (loop 
    943       (wood::with-databases-locked 
     1151      (with-databases-locked 
    9441152       (multiple-value-bind (array index count) 
    945                             (wood::get-disk-page disk-cache address t) 
     1153                            (get-disk-page disk-cache address t) 
    9461154         (declare (fixnum count index)) 
    947          #-ppc-target 
    948          (lap-inline () 
     1155         #+ccl-68k-target 
     1156         (ccl::lap-inline () 
    9491157           (:variable array index count length string offset) 
    950            (move.l (varg array) atemp0) 
    951            (move.l (varg index) da) 
    952            (getint da) 
    953            (lea (atemp0 da.l $v_data) atemp0) 
    954            (move.l (varg string) atemp1) 
    955            (move.l (varg offset) da) 
    956            (getint da) 
    957            (lea (atemp1 da.l $v_data) atemp1) 
    958            (move.l (varg length) da) 
    959            (if# (gt (cmp.l (varg count) da)) 
    960              (move.l (varg count) da)) 
    961            (getint da) 
    962            (dbfloop.l da 
    963                    (move.b atemp1@+ atemp0@+))) 
    964          #+ppc-target 
    965          (%copy-ivector-to-ivector 
     1158           (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1159           (ccl::move.l (ccl::varg index) ccl::da) 
     1160           (ccl::getint ccl::da) 
     1161           (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1162           (ccl::move.l (ccl::varg string) ccl::atemp1) 
     1163           (ccl::move.l (ccl::varg offset) ccl::da) 
     1164           (ccl::getint ccl::da) 
     1165           (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 
     1166           (ccl::move.l (ccl::varg length) ccl::da) 
     1167           (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 
     1168             (ccl::move.l (ccl::varg count) ccl::da)) 
     1169           (ccl::getint ccl::da) 
     1170           (ccl::dbfloop.l ccl::da 
     1171                   (ccl::move.b ccl::atemp1@+ ccl::atemp0@+))) 
     1172         #-ccl-68k-target 
     1173         (copy-as-byte-vector 
    9661174          string offset array index 
    9671175          (if (< count length) count length)) 
     
    9721180  string) 
    9731181 
    974 (defun wood::store-byte-array (byte-array disk-cache address length &optional 
    975                                           (start 0) trust-me?) 
     1182       
     1183(defun-inline store-bytes-from-string (byte-array disk-cache address length) 
     1184  (ensure-byte-array byte-array) 
     1185  (store-bytes-from-ivector byte-array disk-cache address length)) 
     1186   
     1187(defun-inline store-bytes-from-bit-vector (bitvector disk-cache address length) 
     1188  (assert (typep bitvector '(simple-array (unsigned-byte 1) (*)))) 
     1189  (store-bytes-from-ivector bitvector disk-cache address length)) 
     1190 
     1191(defun store-bytes-from-ivector (ivector disk-cache address length) 
     1192  (declare (special *subtype->bytes-per-element* *subtype->array-byte-offset*)) 
     1193  (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset ivector) 
     1194    (let* ((subtype (uvector-subtype ivector)) 
     1195           (byte-offset (+ (* offset (svref *subtype->bytes-per-element* subtype)) 
     1196                           #+LispWorks (svref *subtype->array-byte-offset* subtype)))) 
     1197      (store-bytes-as-byte-vector inner-array disk-cache address length byte-offset)))) 
     1198 
     1199#+LispWorks 
     1200(defun store-bytes-from-iarray (array disk-cache address num-bytes) 
     1201  ;; Array is a non-displaced array of immediate data.  I won't even begin to guess at the 
     1202  ;; internal format. 
     1203  (let* ((num-elts (array-total-size array)) 
     1204         (ivector (make-array num-elts :element-type (array-element-type array)))) 
     1205    (loop for i from 0 below num-elts 
     1206          do (setf (aref ivector i) (row-major-aref array i))) 
     1207    (store-bytes-from-ivector ivector disk-cache address num-bytes) 
     1208    array)) 
     1209 
     1210 
     1211(defun store-bytes-as-byte-vector (byte-array disk-cache address length start) 
    9761212  (setq length (require-type length 'fixnum)) 
    9771213  (setq start (require-type start 'fixnum)) 
    9781214  (locally (declare (fixnum length)) 
    979     (when (> (+ address length) (wood::disk-cache-size disk-cache)) 
     1215    (when (> (+ address length) (disk-cache-size disk-cache)) 
    9801216      (error "Attempt to read past EOF")) 
    9811217    (multiple-value-bind (inner-array offset) (lenient-array-data-and-offset byte-array) 
    982       (unless trust-me?                 ; for p-load-ivector 
    983         (ensure-byte-array byte-array) 
    984         (if (> (+ start length) (uvector-bytes byte-array)) 
    985           (error "(~s ~s) < ~s" 'uvector-bytes byte-array (+ start length)))) 
    9861218      (incf offset start) 
    9871219      (loop 
    988         (wood::with-databases-locked 
     1220        (with-databases-locked 
    9891221         (multiple-value-bind (array index count) 
    990                               (wood::get-disk-page disk-cache address t) 
     1222                              (get-disk-page disk-cache address t) 
    9911223           (declare (fixnum count index)) 
    992            #-ppc-target 
    993            (lap-inline () 
     1224           #+ccl-68k-target 
     1225           (ccl::lap-inline () 
    9941226             (:variable array index count length inner-array offset) 
    995              (move.l (varg array) atemp0) 
    996              (move.l (varg index) da) 
    997              (getint da) 
    998              (lea (atemp0 da.l $v_data) atemp0) 
    999              (move.l (varg inner-array) atemp1) 
    1000              (move.l (varg offset) da) 
    1001              (getint da) 
    1002              (lea (atemp1 da.l $v_data) atemp1) 
    1003              (move.l (varg length) da) 
    1004              (if# (gt (cmp.l (varg count) da)) 
    1005                (move.l (varg count) da)) 
    1006              (getint da) 
    1007              (dbfloop.l da 
    1008                      (move.b atemp1@+ atemp0@+))) 
    1009            #+ppc-target 
    1010            (%copy-ivector-to-ivector 
     1227             (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1228             (ccl::move.l (ccl::varg index) ccl::da) 
     1229             (ccl::getint ccl::da) 
     1230             (lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1231             (ccl::move.l (ccl::varg inner-array) ccl::atemp1) 
     1232             (ccl::move.l (ccl::varg offset) ccl::da) 
     1233             (ccl::getint ccl::da) 
     1234             (ccl::lea (ccl::atemp1 ccl::da.l ccl::$v_data) ccl::atemp1) 
     1235             (ccl::move.l (ccl::varg length) ccl::da) 
     1236             (ccl::if# (ccl::gt (ccl::cmp.l (ccl::varg count) ccl::da)) 
     1237               (ccl::move.l (ccl::varg count) ccl::da)) 
     1238             (ccl::getint ccl::da) 
     1239             (ccl::dbfloop.l ccl::da 
     1240                     (ccl::move.b ccl::atemp1@+ ccl::atemp0@+))) 
     1241           #-ccl-68k-target 
     1242           (copy-as-byte-vector 
    10111243            inner-array offset array index 
    10121244            (if (< count length) count length)) 
    10131245           (when (<= (decf length count) 0) 
    10141246             (return)) 
    1015            (incf address (the fixnum (+ count wood::$block-overhead))) 
     1247           (incf address (the fixnum (+ count $block-overhead))) 
    10161248           (incf offset count)))))) 
    10171249  byte-array) 
    10181250 
    1019 (defun wood::fill-long (disk-cache address value count &optional immediate?) 
     1251 
     1252(defun fill-long (disk-cache address value count &optional immediate?) 
    10201253  (let ((count (require-type count 'fixnum))) 
    10211254    (declare (fixnum count)) 
    10221255    (unless (eql 0 (logand 1 address)) 
    10231256      (error "Odd address: ~s" address)) 
    1024     (when (<= count 0) (return-from wood::fill-long) nil) 
     1257    (when (<= count 0) (return-from fill-long) nil) 
    10251258    (let ((min-size (+ address (ash count 2)))) 
    1026       (when (< (wood::disk-cache-size disk-cache) min-size) 
    1027         (wood::extend-disk-cache disk-cache min-size))) 
     1259      (when (< (disk-cache-size disk-cache) min-size) 
     1260        (extend-disk-cache disk-cache min-size))) 
    10281261    (loop 
    1029       (wood::with-databases-locked 
     1262      (with-databases-locked 
    10301263       (multiple-value-bind (vector offset size) 
    1031                             (wood::get-disk-page disk-cache address t) 
     1264                            (get-disk-page disk-cache address t) 
    10321265         (declare (fixnum offset size)) 
    10331266         (when (<= size 0) 
     
    10361269           (declare (fixnum words)) 
    10371270           (if (< count words) (setq words count)) 
    1038            #-ppc-target 
    1039            (lap-inline () 
     1271           #+ccl-68k-target 
     1272           (ccl::lap-inline () 
    10401273             (:variable vector offset words value immediate?) 
    1041              (move.l (varg value) arg_z) 
    1042              (if# (eq (cmp.l (varg immediate?) nilreg)) 
    1043                (jsr_subprim $sp-getxlong) 
    1044                else# 
    1045                (movereg arg_z acc)) 
    1046              (move.l (varg vector) atemp0) 
    1047              (move.l (varg offset) da) 
    1048              (getint da) 
    1049              (lea (atemp0 da.l $v_data) atemp0) 
    1050              (move.l (varg words) da) 
    1051              (getint da) 
    1052              (dbfloop.l da (move.l acc atemp0@+))) 
    1053            #+ppc-target 
     1274             (ccl::move.l (ccl::varg value) ccl::arg_z) 
     1275             (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 
     1276               (ccl::jsr_subprim ccl::$sp-getxlong) 
     1277               ccl::else# 
     1278               (ccl::movereg ccl::arg_z ccl::acc)) 
     1279             (ccl::move.l (ccl::varg vector) ccl::atemp0) 
     1280             (ccl::move.l (ccl::varg offset) ccl::da) 
     1281             (ccl::getint ccl::da) 
     1282             (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1283             (ccl::move.l (ccl::varg words) ccl::da) 
     1284             (ccl::getint ccl::da) 
     1285             (ccl::dbfloop.l ccl::da (ccl::move.l ccl::acc ccl::atemp0@+))) 
     1286           #-ccl-68k-target 
    10541287           (if immediate? 
    10551288             (dotimes (i words) 
    1056                (wood::%%store-pointer value vector offset t) 
     1289               (%%store-pointer value vector offset t) 
    10571290               (incf offset 4)) 
    10581291             (dotimes (i words) 
     
    10601293               (incf offset 4))) 
    10611294           (if (<= (decf count words) 0) (return))) 
    1062          (incf address (the fixnum (+ size wood::$block-overhead)))))))) 
    1063  
    1064 (defun wood::fill-word (disk-cache address value count &optional immediate?) 
     1295         (incf address (the fixnum (+ size $block-overhead)))))))) 
     1296 
     1297(defun fill-word (disk-cache address value count &optional immediate?) 
    10651298  (declare (ignore immediate?)) 
    10661299  (let ((count (require-type count 'fixnum)) 
     
    10701303    (unless (eql 0 (logand 1 address)) 
    10711304      (error "Odd address: ~s" address)) 
    1072     (when (<= count 0) (return-from wood::fill-word) nil) 
     1305    (when (<= count 0) (return-from fill-word) nil) 
    10731306    (let ((min-size (+ address (ash count 1)))) 
    1074       (when (< (wood::disk-cache-size disk-cache) min-size) 
    1075         (wood::extend-disk-cache disk-cache min-size))) 
     1307      (when (< (disk-cache-size disk-cache) min-size) 
     1308        (extend-disk-cache disk-cache min-size))) 
    10761309    (loop 
    1077       (wood::with-databases-locked 
     1310      (with-databases-locked 
    10781311       (multiple-value-bind (vector offset size) 
    1079                             (wood::get-disk-page disk-cache address t) 
     1312                            (get-disk-page disk-cache address t) 
    10801313         (declare (fixnum offset size)) 
    10811314         (when (<= size 0) 
     
    10841317           (declare (fixnum words)) 
    10851318           (if (< count words) (setq words count)) 
    1086            #-ppc-target 
    1087            (lap-inline () 
     1319           #+ccl-68k-target 
     1320           (ccl::lap-inline () 
    10881321             (:variable vector offset words value) 
    1089              (move.l (varg vector) atemp0) 
    1090              (move.l (varg offset) da) 
    1091              (getint da) 
    1092              (lea (atemp0 da.l $v_data) atemp0) 
    1093              (move.l (varg words) da) 
    1094              (getint da) 
    1095              (move.l (varg value) acc) 
    1096              (getint acc) 
    1097              (dbfloop.l da (move.w acc atemp0@+))) 
     1322             (ccl::move.l (ccl::varg vector) ccl::atemp0) 
     1323             (ccl::move.l (ccl::varg offset) ccl::da) 
     1324             (ccl::getint ccl::da) 
     1325             (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1326             (ccl::move.l (ccl::varg words) ccl::da) 
     1327             (ccl::getint ccl::da) 
     1328             (ccl::move.l (ccl::varg value) ccl::acc) 
     1329             (ccl::getint ccl::acc) 
     1330             (ccl::dbfloop.l ccl::da (ccl:move.w ccl::acc ccl::atemp0@+))) 
    10981331           #+ppc-target 
    10991332           (locally (declare (type (simple-array (unsigned-byte 16) (*)) vector) 
     
    11041337                 (setf (aref vector word-offset) value) 
    11051338                 (incf word-offset)))) 
     1339           #-ccl 
     1340           (dotimes (i words) 
     1341             (%%store-word value vector offset) 
     1342             (incf offset 2)) 
    11061343           (if (<= (decf count words) 0) (return))) 
    1107          (incf address (the fixnum (+ size wood::$block-overhead)))))))) 
    1108  
    1109 (defun wood::fill-byte (disk-cache address value count &optional immediate?) 
     1344         (incf address (the fixnum (+ size $block-overhead)))))))) 
     1345 
     1346(defun fill-byte (disk-cache address value count &optional immediate?) 
    11101347  (declare (ignore immediate?)) 
    11111348  (let ((count (require-type count 'fixnum)) 
     
    11131350        (value (require-type value 'fixnum))) 
    11141351    (declare (fixnum count)) 
    1115     (when (<= count 0) (return-from wood::fill-byte) nil) 
     1352    (when (<= count 0) (return-from fill-byte) nil) 
    11161353    (let ((min-size (+ address count))) 
    1117       (when (< (wood::disk-cache-size disk-cache) min-size) 
    1118         (wood::extend-disk-cache disk-cache min-size))) 
     1354      (when (< (disk-cache-size disk-cache) min-size) 
     1355        (extend-disk-cache disk-cache min-size))) 
    11191356    (loop 
    1120       (wood::with-databases-locked 
     1357      (with-databases-locked 
    11211358       (multiple-value-bind (vector offset size) 
    1122                             (wood::get-disk-page disk-cache address t) 
     1359                            (get-disk-page disk-cache address t) 
    11231360         (declare (fixnum offset size)) 
    11241361         (when (<= size 0) 
    11251362           (error "attempt to write past end of ~s" disk-cache)) 
    11261363         (if (< count size) (setq size count)) 
    1127          #-ppc-target 
    1128          (lap-inline () 
     1364         #+ccl-68k-target 
     1365         (ccl::lap-inline () 
    11291366           (:variable vector offset size value) 
    1130            (move.l (varg vector) atemp0) 
    1131            (move.l (varg offset) da) 
    1132            (getint da) 
    1133            (lea (atemp0 da.l $v_data) atemp0) 
    1134            (move.l (varg size) da) 
    1135            (getint da) 
    1136            (move.l (varg value) acc) 
    1137            (getint acc) 
    1138            (dbfloop.l da (move.b acc atemp0@+))) 
    1139          #+ppc-target 
     1367           (ccl::move.l (ccl::varg vector) ccl::atemp0) 
     1368           (ccl::move.l (ccl::varg offset) ccl::da) 
     1369           (ccl::getint ccl::da) 
     1370           (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1371           (ccl::move.l (ccl::varg size) ccl::da) 
     1372           (ccl::getint ccl::da) 
     1373           (ccl::move.l (ccl::varg value) ccl::acc) 
     1374           (ccl::getint ccl::acc) 
     1375           (ccl::dbfloop.l ccl::da (ccl::move.b ccl::acc ccl::atemp0@+))) 
     1376         #-ccl-68k-target 
    11401377         (locally (declare (type (simple-array (unsigned-byte 8) (*)) vector) 
    11411378                           (optimize (speed 3) (safety 0))) 
     
    11441381             (incf offset))) 
    11451382         (if (<= (decf count size) 0) (return)) 
    1146          (incf address (the fixnum (+ size wood::$block-overhead)))))))) 
    1147  
    1148 (defun wood::array-fill-long (array address value count &optional immediate?) 
     1383         (incf address (the fixnum (+ size $block-overhead)))))))) 
     1384 
     1385(defun array-fill-long (array address value count &optional immediate?) 
    11491386  (ensure-byte-array array) 
    11501387  (let ((count (require-type count 'fixnum)) 
     
    11551392    (unless (eql 0 (the fixnum (logand 1 address))) 
    11561393      (error "Odd address: ~s" address)) 
    1157     #-ppc-target 
    1158     (lap-inline () 
     1394    #+ccl-68k-target 
     1395    (ccl::lap-inline () 
    11591396      (:variable array address value count immediate?) 
    1160       (move.l (varg array) atemp0) 
    1161       (move.l (varg value) acc) 
    1162       (if# (eq (cmp.l (varg immediate?) nilreg)) 
    1163         (movereg acc arg_z) 
    1164         (jsr_subprim $sp-getxlong)) 
    1165       (move.l (varg address) da) 
    1166       (getint da) 
    1167       (lea (atemp0 da.l $v_data) atemp0) 
    1168       (move.l (varg count) da) 
    1169       (dbfloop.l da (move.l acc atemp0@+))) 
    1170     #+ppc-target 
     1397      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1398      (ccl::move.l (ccl::varg value) ccl::acc) 
     1399      (ccl::if# (ccl::eq (ccl::cmp.l (ccl::varg immediate?) ccl::nilreg)) 
     1400        (ccl::movereg ccl::acc ccl::arg_z) 
     1401        (ccl::jsr_subprim ccl::$sp-getxlong)) 
     1402      (ccl::move.l (ccl::varg address) ccl::da) 
     1403      (ccl::getint ccl::da) 
     1404      (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1405      (ccl::move.l (ccl::varg count) ccl::da) 
     1406      (ccl::dbfloop.l ccl::da (ccl::move.l ccl::acc ccl::atemp0@+))) 
     1407    #-ccl-68k-target 
    11711408    (let ((offset address)) 
    11721409      (declare (fixnum offset)) 
    11731410      (if immediate? 
    11741411        (dotimes (i count) 
    1175           (wood::%%store-pointer value array offset t) 
     1412          (%%store-pointer value array offset t) 
    11761413          (incf offset 4)) 
    11771414        (dotimes (i count) 
     
    11801417  nil) 
    11811418 
    1182 (defun wood::array-fill-word (array address value count) 
     1419(defun array-fill-word (array address value count) 
    11831420  (ensure-byte-array array) 
    11841421  (let ((count (require-type count 'fixnum)) 
     
    11891426    (unless (eql 0 (the fixnum (logand 1 address))) 
    11901427      (error "Odd address: ~s" address)) 
    1191     #-ppc-target 
    1192     (lap-inline () 
     1428    #+ccl-68k-target 
     1429    (ccl::lap-inline () 
    11931430      (:variable array address value count) 
    1194       (move.l (varg array) atemp0) 
    1195       (move.l (varg value) acc) 
    1196       (getint acc) 
    1197       (move.l (varg address) da) 
    1198       (getint da) 
    1199       (lea (atemp0 da.l $v_data) atemp0) 
    1200       (move.l (varg count) da) 
    1201       (dbfloop.l da (move.w acc atemp0@+))) 
     1431      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1432      (ccl::move.l (ccl::varg value) ccl::acc) 
     1433      (ccl::getint ccl::acc) 
     1434      (ccl::move.l (ccl::varg address) ccl::da) 
     1435      (ccl::getint ccl::da) 
     1436      (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1437      (ccl::move.l (ccl::varg count) ccl::da) 
     1438      (ccl::dbfloop.l ccl::da (ccl::move.w ccl::acc ccl::atemp0@+))) 
    12021439    #+ppc-target 
    12031440    (let ((index (ash address -1))) 
     
    12071444      (dotimes (i count) 
    12081445        (setf (aref array index) value) 
    1209         (incf index)))) 
     1446        (incf index))) 
     1447    #-ccl 
     1448    (dotimes (i count) 
     1449      (declare (fixnum i)) 
     1450      (%%store-word value array address) 
     1451      (incf address 2))) 
    12101452  nil) 
    12111453 
    1212 (defun wood::array-fill-byte (array address value count) 
     1454(defun array-fill-byte (array address value count) 
    12131455  (ensure-byte-array array) 
    12141456  (let ((count (require-type count 'fixnum)) 
     
    12171459    (declare (fixnum count address)) 
    12181460    (check-byte-array-address address count array) 
    1219     #-ppc-target 
    1220     (lap-inline () 
     1461    #+ccl-68k-target 
     1462    (ccl::lap-inline () 
    12211463      (:variable array address value count) 
    1222       (move.l (varg array) atemp0) 
    1223       (move.l (varg value) acc) 
    1224       (getint acc) 
    1225       (move.l (varg address) da) 
    1226       (getint da) 
    1227       (lea (atemp0 da.l $v_data) atemp0) 
    1228       (move.l (varg count) da) 
    1229       (getint da) 
    1230       (dbfloop.l da (move.b acc atemp0@+))) 
    1231     #+ppc-target 
     1464      (ccl::move.l (ccl::varg array) ccl::atemp0) 
     1465      (ccl::move.l (ccl::varg value) ccl::acc) 
     1466      (ccl::getint ccl::acc) 
     1467      (ccl::move.l (ccl::varg address) ccl::da) 
     1468      (ccl::getint ccl::da) 
     1469      (ccl::lea (ccl::atemp0 ccl::da.l ccl::$v_data) ccl::atemp0) 
     1470      (ccl::move.l (ccl::varg count) ccl::da) 
     1471      (ccl::getint ccl::da) 
     1472      (ccl::dbfloop.l ccl::da (ccl::move.b ccl::acc ccl::atemp0@+))) 
     1473    #-ccl-68k-target 
    12321474    (let ((offset address)) 
    12331475      (declare (fixnum offset) 
     
    12411483 
    12421484; some macros to make using this take less typing. 
    1243  
    1244 (in-package :wood) 
    1245  
    12461485(export '(accessing-disk-cache)) 
    12471486 
     
    12811520(defun ensure-accessing-disk-cache (accessor env) 
    12821521  (unless (and (eq :lexical (variable-information '-*dc*- env)) 
    1283                (eq :macro (function-information '-*addr*- env)) 
    1284                (eq :macro (function-information '-*select*- env))) 
    1285     (error "~s called ouside of ~s environment" 
    1286            accessor 'accessing-disk-cache))) 
     1522               #-LispWorks (eq :macro (function-information '-*addr*- env)) 
     1523               #-LispWorks (eq :macro (function-information '-*select*- env))) 
     1524    (error "~s called ouside of ~s environment" accessor 'accessing-disk-cache))) 
    12871525 
    12881526(defmacro load.l (address &environment env) 
     
    14301668 
    14311669#| 
     1670(close-disk-cache dc) 
    14321671(setq wood::dc (wood::open-disk-cache "temp.dc"  
    14331672                                      :if-exists :overwrite 
     
    14571696(require :lapmacros) 
    14581697 
    1459 (defun wood::time-moves (&optional (count 100)) 
     1698(defun time-moves (&optional (count 100)) 
    14601699  (setq count (require-type count 'fixnum)) 
    14611700  (macrolet ((moves (count) 
    1462                `(lap-inline (,count) 
    1463                   (getint arg_z) 
    1464                   (move.l ($ 0) atemp0) 
    1465                   (dbfloop arg_z 
     1701               `(ccl::lap-inline (,count) 
     1702                  (ccl::getint ccl::arg_z) 
     1703                  (ccl::move.l (ccl::$ 0) ccl::atemp0) 
     1704                  (ccl::dbfloop ccl::arg_z 
    14661705                           ,@(make-list 1000  
    14671706                                        :initial-element 
    1468                                         '(move.l atemp0@+ da)))))) 
     1707                                        '(ccl::move.l ccl::atemp0@+ ccl::da)))))) 
    14691708    (moves count) 
    14701709    (* count 1000))) 
  • lw-branch/disk-cache.lisp

    r3 r6  
    66;; Code to support a cached byte I/O stream. 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2122;; Modification History 
    2223;; 
     24;; 02/01/06 gz   LispWorks port 
    2325;; ------------- 0.96 
    2426;; ------------- 0.95 
     
    100102;; 
    101103 
    102 (defpackage :wood) 
    103104(in-package :wood) 
    104105 
     
    274275   (setf (disk-page-flags disk-page) 
    275276         (if value 
    276            (ccl::bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page)) 
    277            (ccl::bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page)))) 
     277           (%bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page)) 
     278           (%bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page)))) 
    278279   (not (null value)))) 
    279280 
     
    290291  (setf (disk-page-flags disk-page) 
    291292        (if value 
    292           (ccl::bitset $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))) 
    293           (ccl::bitclr $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))))) 
     293          (%bitset $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))) 
     294          (%bitclr $disk-page-flags_touched-bit (the fixnum (disk-page-flags disk-page))))) 
    294295  value) 
    295296 
     
    319320; New code 
    320321(defparameter *big-io-buffers* 
    321   (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open))))) 
     322  #+ccl (not (null (find :elements-per-buffer (ccl::lfun-keyvect #'open)))) 
     323  #+LispWorks nil) 
    322324 
    323325(defun open-disk-cache (filename &key shared-p read-only-p 
     
    330332                                    (if-does-not-exist :error) 
    331333                                    (external-format :???? ef-p) 
    332                                     (mac-file-creator :ccl2) 
     334                                    #+ccl (mac-file-creator :ccl2) 
    333335                                    write-hook 
    334336                                    (initial-transaction-p t)) 
     
    346348  (setq max-pages (shared-buffer-max-pages shared-buffer)) 
    347349  (let ((mask (lognot (1- (expt 2 (1- (integer-length page-size))))))) 
     350    #+ccl 
    348351    (if (probe-file filename) 
    349352      (if (and ef-p (neq external-format (mac-file-type filename))) 
     
    359362                         :if-exists if-exists 
    360363                         :if-does-not-exist if-does-not-exist 
    361                          :mac-file-creator mac-file-creator 
     364                         #+ccl :mac-file-creator #+ccl mac-file-creator 
     365                         #+LispWorks :element-type '(unsigned-byte 8) 
    362366                         rest))) 
    363367      (when stream 
     
    525529  (unless (fixnump address) 
    526530    (error "Address is not a fixnum")) 
    527   (locally #+wood-fixnum-addresses 
    528     (declare (fixnum address)) 
     531  (locally  
     532    #+wood-fixnum-addresses (declare (fixnum address)) 
    529533    (let* ((hash (disk-cache-page-hash disk-cache)) 
    530534           (base-address (logand address (the fixnum (disk-cache-mask disk-cache)))) 
     
    540544                (shared-buffer (disk-cache-shared-buffer disk-cache))) 
    541545            #+wood-fixnum-addresses (declare (fixnum max-size)) 
    542             (if (>= address max-size) 
     546            (when (>= address max-size) 
    543547              (if (> address max-size) 
    544548                (error "~s > size of ~s" address disk-cache) 
     
    560564              (setq page (shared-buffer-pages shared-buffer))) 
    561565            ;; Here's the page replacement algorithm, one-bit clock algorithm 
    562             (loop 
     566            (loop ; while disk-page-touched? 
    563567              (unless (disk-page-touched? page) (return)) 
    564568              (setf (disk-page-touched? page) nil) 
     
    669673  (if address 
    670674    (let (ignored-params) 
    671       (multiple-value-bind (body-tail decls) (ccl::parse-body body env nil) 
     675      (multiple-value-bind (body-tail decls) (parse-body body env nil) 
    672676        (flet ((normalize (param &optional (ignoreable? t)) 
    673677                 (or param 
     
    718722       ; increase the file size & install the new size 
    719723       (when extend-file? 
    720          (file-length (disk-cache-stream disk-cache) new-size)) 
     724         (extend-file-length (disk-cache-stream disk-cache) new-size)) 
    721725       (setf (disk-cache-size disk-cache) new-size))))) 
    722726 
     
    727731      (flush-disk-cache dc)))) 
    728732 
    729 (pushnew 'flush-all-disk-caches *lisp-cleanup-functions*) 
     733(register-lisp-cleanup-function 'flush-all-disk-caches) 
    730734 
    731735;;;;;;;;;;;;;;;;;;;;;;; 
     
    794798        (incf address bytes))))) 
    795799 
    796 ; write a string to dc 
    797800(defun wc (string address) 
    798801  (declare (special dc)) 
  • lw-branch/disk-page-hash.lisp

    r3 r6  
    66;; A simple and very fast hashing mechanism for disk pages 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996-1999 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2728;; Modification History 
    2829;; 
     30;; 02/01/06 gz   LispWorks port 
    2931;; 01/10/00 akh moved (pushnew :wood-fixnum-addresses *features*) to block-io-mcl 
    3032;; -------- 0.96 
     
    147149  hash) 
    148150 
    149 (declaim (inline address-iasr)) 
    150  
    151 (defun address-iasr (count address &optional known-fixnum-p) 
    152   (declare (fixnum count)) 
    153   #+wood-fixnum-addresses (declare (fixnum address) (ignore known-fixnum-p)) 
    154   (if #+wood-fixnum-addresses t 
    155       #-wood-fixnum-addresses known-fixnum-p 
    156       (ccl::%iasr count address) 
    157       (ash address (the fixnum (- 0 count))))) 
     151#+wood-fixnum-addresses 
     152(defun-inline address-iasr (count address) 
     153  (declare (fixnum count address)) 
     154  (the fixnum (%iasr count address))) 
     155 
     156#-wood-fixnum-addresses 
     157(defun-inline address-iasr (count address) 
     158  (declare (fixnum count) 
     159           (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     160  #-LispWorks 
     161  (the fixnum (ash address (the fixnum (- 0 count)))) 
     162  #+LispWorks 
     163  (the fixnum (sys:int32-to-integer (sys:int32>> (the integer address) count)))) 
     164 
    158165 
    159166; I wanted this to be an inlined function, but MCL's compiler wouldn't inline the knowledge 
    160167; that address was a fixnum. 
    161168(defmacro %disk-page-gethash-macro (address hash &optional fixnum-address?) 
    162   `(locally (declare (optimize (speed 3) (safety 0))) 
     169  `(locally (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)) 
     170                     ,@(and fixnum-address? '((type fixnum address)))) 
    163171     (if (eql ,address (disk-page-hash-cache-address ,hash)) 
    164172       (disk-page-hash-cache-value ,hash) 
    165        (let* ((page-number (address-iasr (disk-page-hash-page-size-shift ,hash) ,address ,fixnum-address?)) 
     173       (let* ((page-number ,(if fixnum-address? 
     174                              `(%iasr (disk-page-hash-page-size-shift ,hash) ,address) 
     175                              `(address-iasr (disk-page-hash-page-size-shift ,hash) ,address))) 
    166176              (hash-code (logand page-number (the fixnum (disk-page-hash-mask ,hash)))) 
    167               (index (* 2 hash-code)) 
     177              (index (+ hash-code hash-code)) 
    168178              (vector (disk-page-hash-vector ,hash)) 
    169179              (probe (svref vector index))) 
    170          (declare (fixnum hash-code index probe ,@(and fixnum-address? '(page-number))) 
     180         (declare (fixnum hash-code index page-number) 
    171181                  (type simple-vector vector)) 
    172182         (cond ((eql probe ,address) (aref vector (the fixnum (1+ index)))) 
    173                ((eql probe *no-key-marker*) nil) 
     183               ((eq probe *no-key-marker*) nil) 
    174184               (t (let ((secondary-key (aref *secondary-keys* 
    175                                              (ccl::%iasr (disk-page-hash-shift ,hash) 
    176                                                          (logand page-number (the fixnum (disk-page-hash-secondary-mask ,hash)))))) 
     185                                             (%iasr (disk-page-hash-shift ,hash) 
     186                                                    (logand page-number (the fixnum (disk-page-hash-secondary-mask ,hash)))))) 
    177187                        (vector-length (disk-page-hash-vector-length ,hash)) 
    178188                        (original-index index)) 
     
    187197                        (when (eql probe ,address) 
    188198                          (let ((value (aref vector (the fixnum (1+ index))))) 
    189                             (setf (disk-page-hash-cache-address hash) address 
    190                                   (disk-page-hash-cache-value hash) value 
    191                                   (disk-page-hash-cache-index hash) index) 
     199                            (setf (disk-page-hash-cache-address ,hash) ,address 
     200                                  (disk-page-hash-cache-value ,hash) value 
     201                                  (disk-page-hash-cache-index ,hash) index) 
    192202                            (return value))) 
    193                         (when (eql probe *no-key-marker*) 
     203                        (when (eq probe *no-key-marker*) 
    194204                          (return nil))))))))))) 
     205 
     206#| 
     207;(disassemble #'fixnum-disk-page-gethash) 
     208(defun fixnum-disk-page-gethash (address hash) 
     209  (declare (type fixnum address)) 
     210  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
     211  (%disk-page-gethash-macro address hash t)) 
     212|# 
    195213 
    196214; This is one of WOOD's most-called functions. 
    197215; It's important that it be as fast as possible. 
    198 (defun disk-page-gethash (address hash) 
    199   (declare (optimize (speed 3) (safety 0))) 
     216(defun disk-page-gethash (address hash #+LispWorks &optional #+LispWorks ignore) 
     217  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
     218  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
    200219  ; Assume if it's non-null that it's of the right type since 
    201220  ; type check takes too long (unless unlined LAP?). 
     
    204223  (unless hash 
    205224    (error "Null hash table.")) 
    206   (if #+wood-fixnum-addresses t 
    207       #-wood-fixnum-addresses (fixnump address) 
     225  (if #+wood-fixnum-addresses t #-wood-fixnum-addresses (fixnump address) 
    208226    (locally (declare (fixnum address)) 
    209227      (%disk-page-gethash-macro address hash t)) 
     
    211229 
    212230(defun (setf disk-page-gethash) (value address hash &optional deleting?) 
     231  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
    213232  #+wood-fixnum-addresses (declare (fixnum address)) 
    214233  (unless (typep hash 'disk-page-hash) 
     
    219238        (if deleting? 
    220239          (let ((vector (disk-page-hash-vector hash))) 
    221             (setf (disk-page-hash-cache-address hash) nil 
     240            (setf (disk-page-hash-cache-address hash) nil ; 
    222241                  (disk-page-hash-cache-value hash) nil 
    223242                  (disk-page-hash-cache-index hash) nil 
     
    240259            (eql probe *no-key-marker*) 
    241260            (let ((secondary-key (aref *secondary-keys* 
    242                                        (ccl::%iasr (disk-page-hash-shift hash) 
    243                                                    (logand page-number (the fixnum (disk-page-hash-secondary-mask hash)))))) 
     261                                       (%iasr (disk-page-hash-shift hash) 
     262                                              (logand page-number (the fixnum (disk-page-hash-secondary-mask hash)))))) 
    244263                  (vector-length (length vector)) 
    245264                  (first-deletion nil) 
     
    299318    (declare (fixnum index length)) 
    300319    (loop 
    301       (let ((key (ccl::%svref vector index)) 
    302             (value (ccl::%svref vector (incf index)))) 
     320      (let ((key (%svref vector index)) 
     321            (value (%svref vector (incf index)))) 
    303322        (incf index) 
    304323        (unless (or (eql key *no-key-marker*) (eql key *deleted-key-marker*)) 
     
    323342; takes a long time, so we get rid of the delted markers to speed it up. 
    324343(defun disk-page-rehash (hash address value) 
     344  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))) 
    325345  (locally 
    326346    (declare (optimize (speed 3) (safety 0))) 
     
    340360      (declare (type simple-vector vector) 
    341361               (fixnum vector-length page-size-shift mask shift secondary-mask loop-index loop-index+1)) 
    342       #-wood-fixnum-addresses (declare (fixnum minus-page-size-shift)) 
    343362      (flet ((bit-ref (bits index) 
    344363               (declare (type (simple-array (unsigned-byte 8) (*)) bits) 
     
    395414                              (setf (bit-ref bits index) 1)) 
    396415                             (t nil))))) 
    397               (declare (dynamic-extent insert-p)) 
     416              (declare (dynamic-extent #'insert-p)) 
    398417              (unless (insert-p (svref vector index)) 
    399418                (let ((secondary-key (aref *secondary-keys* 
    400                                            (ccl::%iasr shift (logand page-number secondary-mask))))) 
     419                                           (%iasr shift (logand page-number secondary-mask))))) 
    401420                  (declare (fixnum secondary-key)) 
    402421                  (loop 
  • lw-branch/example.lisp

    r3 r6  
    1 ;;;-*- Mode: Lisp; Package: cl-user 
     1;;;-*- Mode: Lisp; Package: cl-user -*- 
    22;;; 
    33;;; example.lisp 
     
    101101 
    102102(defun store-person (pheap person) 
    103   (setq person (require-type person 'person)) 
     103  (setq person (wood::require-type person 'person)) 
    104104  (multiple-value-bind (ss#->person last-name->person-list) 
    105105                       (person-pheap-tables pheap) 
     
    125125     (wood:p-btree-lookup last-name->person-list (string-upcase last-name))))) 
    126126 
    127 (defun print-people-by-ss# (pheap) 
    128   (let ((ss#->person (person-pheap-tables pheap))) 
     127(defun print-people-by-ss# (pheap &optional (stream t)) 
     128  (let ((ss#->person (person-pheap-tables pheap)) 
     129        (index -1)) 
    129130    (wood:p-map-btree ss#->person 
    130131                      #'(lambda (ss# person) 
    131                           (format t "~&~a ~s~%" ss# (wood:p-load person)))))) 
    132  
    133 (defun print-people-by-last-name (pheap) 
     132                          (format stream "~&#~2,' d: ~a ~s~%" 
     133                                  (incf index) 
     134                                  ss# (wood:p-load person)))))) 
     135 
     136(defun print-people-by-last-name (pheap &optional (stream t)) 
    134137  (multiple-value-bind (ss#->person last-name->person-list) 
    135138                       (person-pheap-tables pheap) 
     
    144147                                      :key 'person-first-name)) 
    145148                          (dolist (person person-list) 
    146                             (format t "~&~s~%" person)))))) 
     149                            (format stream "~&~s~%" person)))))) 
    147150 
    148151;; Code for creating random PERSON instances. 
     
    217220 
    218221#| 
     222(defun listener-stream () 
     223  "Find the stream to the listener's main pane." 
     224  (let* ((listener (capi:locate-interface 'lispworks-tools:listener)) 
     225         (pane (and listener (capi:interface-editor-pane listener))) 
     226         (stream (and pane (capi:interactive-pane-stream pane)))) 
     227    stream)) 
     228 
     229(defvar *random-people* (loop for i from 0 below 100 collect (random-person))) 
     230(let ((stream (listener-stream))) 
     231  (loop for p in (subseq *random-people* 0 18) 
     232        do (format stream "~&  (make-instance 'person :first-name ~s :last-name ~s :age ~s :sex '~s :occupation ~s :ss# ~s)" 
     233                   (person-first-name p) (person-last-name p) (person-age p) 
     234                   (person-sex p) (person-occupation p) (person-ss# p)))) 
     235 
     236(defparameter *people* 
     237 (list 
     238  (make-instance 'person :first-name "Melissa" :last-name "Smith" :age #x60 :sex '\F :occupation "Cop" :ss# "232436212") 
     239  (make-instance 'person :first-name "Matthew" :last-name "Wilson" :age #x5D :sex 'M :occupation "Candlestick Maker" :ss# "859110137") 
     240  (make-instance 'person :first-name "Steve" :last-name "Johnson" :age #x1 :sex 'M :occupation "Cashier" :ss# "140739951") 
     241  (make-instance 'person :first-name "Gail" :last-name "Wilson" :age #x4A :sex '\F :occupation "Baker" :ss# "209354283") 
     242  (make-instance 'person :first-name "Dan" :last-name "Johnson" :age #x4 :sex 'M :occupation "Hacker" :ss# "809159982") 
     243  (make-instance 'person :first-name "Melissa" :last-name "Jones" :age #x3 :sex '\F :occupation "Doctor" :ss# "672195544") 
     244  (make-instance 'person :first-name "Alice" :last-name "Riley" :age #x4F :sex '\F :occupation "Dentist" :ss# "218397663") 
     245  (make-instance 'person :first-name "Hillary" :last-name "Riley" :age #x2D :sex '\F :occupation "Insurance Sales" :ss# "573610849") 
     246  (make-instance 'person :first-name "Andrew" :last-name "Peterson" :age #x5 :sex 'M :occupation "Engineer" :ss# "714724948") 
     247  (make-instance 'person :first-name "Christie" :last-name "Kennedy" :age #x1E :sex '\F :occupation "Butcher" :ss# "677765239") 
     248  (make-instance 'person :first-name "Karla" :last-name "O'Neil" :age #x1C :sex '\F :occupation "Butcher" :ss# "219308385") 
     249  (make-instance 'person :first-name "Elizabeth" :last-name "Wilson" :age #x57 :sex '\F :occupation "Butcher" :ss# "249274187") 
     250  (make-instance 'person :first-name "Elizabeth" :last-name "Riley" :age #x3B :sex '\F :occupation "Doctor" :ss# "489650772") 
     251  (make-instance 'person :first-name "Irving" :last-name "Kennedy" :age #x46 :sex 'M :occupation "Doctor" :ss# "899583677") 
     252  (make-instance 'person :first-name "Susan" :last-name "Riley" :age #x2B :sex '\F :occupation "Cashier" :ss# "504945523") 
     253  (make-instance 'person :first-name "Hillary" :last-name "Wilson" :age #x45 :sex '\F :occupation "Politician" :ss# "437348938") 
     254  (make-instance 'person :first-name "Joe" :last-name "Riley" :age #x31 :sex 'M :occupation "Politician" :ss# "170903308") 
     255  (make-instance 'person :first-name "Matthew" :last-name "Riley" :age #x4B :sex 'M :occupation "Advertising" :ss# "773725302"))) 
     256 
     257 
     258 
     259 
     260 
     261(delete-file "test1.wood") 
     262(setq p (create-person-file :filename "test1.wood" :if-exists :supersede)) 
     263(loop for person in *people* do (store-person p person)) 
     264(wood:close-pheap p) 
     265 
     266 
     267;;; (inspect p) 
     268;;; (WOOD::VERIFY-DEBUG-OBJECTS p) 
     269 
     270(setq pp (wood:open-pheap "test1.wood")) 
     271(print-people-by-ss# pp *trace-output*) 
     272(print-people-by-last-name pp (listener-stream)) 
     273(print-people-by-last-name pp *trace-output*) 
     274(wood:close-pheap pp) 
     275 
     276|# 
     277 
     278#| 
    219279(defparameter *p* (create-person-file :if-exists :supersede)) 
    220280; or 
  • lw-branch/load-wood.lisp

    r3 r6  
    77;; You may need to edit the definition of the "wood" logical host. 
    88;; 
     9;; Portions Copyright © 2006 Clozure Associates 
    910;; Copyright © 1996 Digitool, Inc. 
    1011;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2223;; Modification History 
    2324;; 
     25;; 02/01/06 gz    LispWorks port 
    2426;; 04/11/97 bill  compile-and-load checks for "Wrong PFSL version" as well 
    2527;;                as "Wrong FASL version". 
     
    7779                ccl::databases-locked-p 
    7880                ccl::funcall-with-databases-unlocked 
    79                 ccl::with-databases-unlocked)) 
     81                ccl::with-databases-unlocked) 
     82  (:export #:load-wood 
     83           #:open-pheap #:close-pheap #:with-open-pheap #:root-object #:flush-pheap 
     84           #:make-shared-buffer #:make-shared-buffer-pool 
     85           #:pheap #:p-loading-pheap 
     86           #:p-load #:p-store #:p-stored? #:p-loaded? 
     87           #:p-make-area #:with-consing-area 
     88           #:p-cons #:p-list #:p-list-in-area #:p-make-list 
     89           #:p-make-uvector #:p-make-array #:p-vector 
     90           #:p-listp #:p-consp #:p-atom #:p-uvectorp #:p-packagep #:p-symbolp 
     91           #:p-stringp #:p-simple-string-p #:p-vectorp #:p-simple-vector-p #:p-arrayp 
     92           #:pload-barrier-p  
     93           #:p-car #:p-cdr #:p-caar #:p-cadr #:p-cdar #:p-cddr 
     94           #:p-caaar #:p-caadr #:p-cadar #:p-caddr #:p-cdaar #:p-cdadr #:p-cddar 
     95           #:p-cdddr #:p-caaaar #:p-caaadr #:p-caadar #:p-caaddr #:p-cadaar 
     96           #:p-cadadr #:p-caddar #:p-cadddr #:p-cdaaar #:p-cdaadr #:p-cdadar 
     97           #: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 
     101           #:p-aref #: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 #:opened-pheap 
     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          )) 
    80122 
    81123(in-package :wood) 
    82124 
    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           )) 
     125; Assume fixnum addresses. 
     126; Comment out this form to compile Wood for files larger than 256 megs (8 Megs in LWW) 
     127#-LispWorks4 ;; LWW4 fixnums are tiny. 
     128(eval-when (:compile-toplevel :execute :load-toplevel) 
     129  (pushnew :wood-fixnum-addresses *features*)) 
     130 
     131;; For simpler conditionalizations 
     132#+(and ccl (not ppc-target)) 
     133(eval-when (:compile-toplevel :execute :load-toplevel) 
     134  (pushnew :ccl-68k-target *features*)) 
     135 
     136#| 
     137#+LispWorks 
     138(eval-when (:compile-toplevel :execute :load-toplevel) 
     139  ;; For some reason, in lispworks the SYSTEM package has the nickname :CCL, which makes it harder 
     140  ;; to catch porting errors here.  This can be removed once the port is complete. 
     141  (let ((pkg (find-package "CCL"))) 
     142    (when pkg 
     143      (rename-package pkg (package-name pkg) (remove "CCL" (package-nicknames pkg) :test #'equal))))) 
     144|# 
     145 
     146 
     147;; #+ccl (... #_Foo ...) errs out because #_ is undefined. 
     148#+LispWorks 
     149(eval-when (:compile-toplevel :execute :load-toplevel) 
     150  (when (null (get-dispatch-macro-character #\# #\_)) 
     151    (set-dispatch-macro-character #\# #\_ 
     152                                  #'(lambda(s c n) 
     153                                      (declare (ignore c n)) 
     154                                      (read s nil nil t) 
     155                                      nil)))) 
    122156 
    123157(setf (logical-pathname-translations "wood") 
    124       (let ((path (or *load-pathname* *loading-file-source-file*))) 
     158      (let ((path (or *load-pathname* #+ccl *loading-file-source-file* 
     159                      #+LispWorks dspec:*source-pathname* 
     160                      #+LispWorks system:*current-pathname*))) 
    125161        (if path 
    126162          (let* ((dest-dir (make-pathname :device    (pathname-device path) 
     
    141177          '(("wood;**;*.*" "ccl:wood;**;*.*"))))) 
    142178 
     179(defun fasl-pathname (pathname) 
     180  (merge-pathnames pathname 
     181                   #+ccl ccl::*.fasl-pathname* 
     182                   #+lispworks (make-pathname :type system:*binary-file-type*))) 
     183   
     184(defvar *debug-wood* nil) 
     185 
    143186(defun compile-if-needed (file &optional force) 
    144187  (let ((lisp (merge-pathnames file ".lisp")) 
    145         (fasl (merge-pathnames file ccl::*.fasl-pathname*))) 
     188        (fasl (fasl-pathname file))) 
    146189    (when (or force 
    147190              (not (probe-file fasl)) 
    148191              (> (file-write-date lisp) (file-write-date fasl))) 
    149       (compile-file lisp :verbose t)))) 
     192      (compiler:with-optimization-level 
     193        (if *debug-wood* 
     194          (compiler::set-optimization-level :safety 3 :debug 3) 
     195          (compiler::set-optimization-level :speed 3 :safety 0 :debug 0 :float 0)) 
     196        (compile-file lisp :verbose t))))) 
    150197 
    151198(defun compile-and-load (file &optional force-compile) 
    152199  (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))))) 
     200  (handler-bind ((simple-error 
     201                  #'(lambda (condition) 
     202                      (if (member (simple-condition-format-string condition) 
     203                                  '("Wrong FASL version." "Wrong PFSL version.") 
     204                                  :test 'equalp) 
     205                        (progn 
     206                          (format t "~&;Deleting FASL file from other MCL version...") 
     207                          (delete-file (fasl-pathname file)) 
     208                          (return-from compile-and-load (compile-and-load file force-compile))) 
     209                        (error condition))))) 
     210    (load file :verbose t))) 
    164211 
    165212(defparameter *wood-files* 
    166   '("block-io-mcl" "split-lfun" "q" 
     213  '("compat" 
     214    #+ccl "block-io-mcl" #+ccl "split-lfun" 
     215    "q" 
    167216    "disk-page-hash" "disk-cache" "woodequ" "disk-cache-accessors" 
    168     "disk-cache-inspector" "persistent-heap" "version-control" 
     217    #+ccl "disk-cache-inspector" #+LispWorks "lw-inspector" 
     218    "persistent-heap" "version-control" 
    169219    "btrees" "persistent-clos" 
    170     "recovery" "wood-gc")) 
     220    ;; Not ported yet 
     221    #-LispWorks "recovery" #-LispWorks "wood-gc")) 
    171222 
    172223(defun load-wood (&optional force-compile) 
    173224  (with-compilation-unit () 
    174225    (compile-if-needed "wood:wood;load-wood") 
    175     (unless (boundp 'ccl::*elements-per-buffer*) 
    176       (compile-and-load "wood:patches;big-io-buffer-patch")) 
     226    #-lispworks (unless (boundp 'ccl::*elements-per-buffer*) 
     227                  (compile-and-load "wood:patches;big-io-buffer-patch")) 
    177228    (dolist (file *wood-files*) 
    178229      (compile-and-load (merge-pathnames file "wood:wood;") force-compile)) 
  • lw-branch/persistent-clos.lisp

    r3 r6  
    66;; Support for saving/restoring CLOS instances to/from Wood persistent heaps. 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2122;; Modification History 
    2223;; 
     24;; 02/01/06 gz   LispWorks port 
    2325;; 08/28/98 akh add dc-shared-initialize - fixes case of change class in memory, then write a slot-value to pheap 
    2426;;                left us with the class updated on disk but not the instance-slots with initforms 
     
    156158 
    157159 
     160#+LispWorks 
     161(defparameter $wrapper-names-index 
     162  (or (loop with wrapper = (progn 
     163                             (make-instance 'simple-error) 
     164                             (clos::class-wrapper (find-class 'simple-error))) 
     165            for i in '(0 1 2 -1 -2 -3) 
     166            as val = (%svref wrapper i) 
     167            when (and (consp val) 
     168                      (consp (cdr val)) 
     169                      (null (cddr val)) 
     170                      (equal val '(conditions::format-string conditions::format-arguments))) 
     171            return i) 
     172      (error "Couldn't find wrapper names index"))) 
     173 
     174 
     175 
     176 
     177;; In lispworks, the names are in a list not a vector, but seems to work ok. 
     178(defun-inline %wrapper-instance-slots (wrapper) 
     179  #+ccl (ccl::%wrapper-instance-slots wrapper) 
     180  #-ccl (%svref wrapper $wrapper-names-index)) 
     181 
     182#+LispWorks 
     183(defun class-own-wrapper (class) 
     184  (clos::class-wrapper class)) 
     185 
    158186; This knows internals of MCL's CLOS implementation 
    159187(defun class-slots-vector (class) 
    160   (ccl::%wrapper-instance-slots 
    161    (or (ccl::%class-own-wrapper class) 
    162        (ccl::initialize-class-and-wrapper class)))) 
     188  (%wrapper-instance-slots #+ccl (or (ccl::%class-own-wrapper class) 
     189                                     (ccl::initialize-class-and-wrapper class)) 
     190                           #+LispWorks (clos::class-wrapper class))) 
     191 
    163192 
    164193(defun dc-make-class-slots-vector (disk-cache class &optional 
     
    166195  (%p-store pheap (wood-slot-names-vector (class-prototype class)))) 
    167196 
    168 (def-predicate ccl::classp (p disk-cache pointer) 
     197(def-predicate classp (p disk-cache pointer) 
    169198  (dc-vector-subtype-p disk-cache pointer $v_class)) 
    170199 
     
    203232      (setq wrapper (class-own-wrapper class)) 
    204233      (unless wrapper (error "Can't find class-own-wrapper for ~s" class))) 
    205     (ccl::%wrapper-instance-slots wrapper))) 
     234    (%wrapper-instance-slots wrapper))) 
    206235 
    207236(defun p-instance-class (instance) 
     
    279308    res)) 
    280309 
    281 (def-predicate ccl::standard-instance-p (p disk-cache pointer) 
    282   (dc-vector-subtype-p disk-cache pointer $v_instance)) 
    283  
    284 (def-accessor ccl::instance-class-wrapper (p) (disk-cache pointer) 
     310(def-accessor instance-class-wrapper (p) (disk-cache pointer) 
    285311  (require-satisfies dc-standard-instance-p disk-cache pointer) 
    286312  (dc-%svref disk-cache pointer $instance.wrapper)) 
     
    329355(defun dc-updated-instance-slots (disk-cache instance memory-class pheap &optional 
    330356                                             dont-update) 
     357  ;(assert (dc-vector-subtype-p disk-cache instance $v_instance)) 
    331358  (with-databases-locked 
    332359   (let ((old-wrapper (dc-%svref disk-cache instance $instance.wrapper)) 
     
    401428 
    402429 
     430;;; *** TODO: Need Lispworks version. 
     431#+CCL 
    403432(defun dc-shared-initialize (disk-cache pheap slot-values new-instance-slots class &optional (slot-names t)) 
    404433  ;; I don't know how to find all this stuff in the disk version - I don't think it's there. 
     
    422451     
    423452 
    424 (def-predicate ccl::standard-instance-p (p disk-cache pointer) 
     453(def-predicate standard-instance-p (p disk-cache pointer) 
    425454  (and (dc-uvectorp disk-cache pointer) 
    426        (eq (dc-%vector-subtype disk-cache pointer) $v_instance))) 
     455       (dc-vector-subtype-p disk-cache pointer $v_instance))) 
    427456 
    428457(def-accessor slot-value (p slot-name) (disk-cache pointer) 
     
    516545    pointer)) 
    517546 
     547#+CCL 
    518548(defmethod %p-store-object (pheap (object ccl::funcallable-standard-object) descend) 
    519549  (declare (ignore pheap descend)) 
     
    536566                             (dc-updated-instance-slots disk-cache address class pheap) 
    537567          (dotimes (i (length slot-names)) 
    538             (let ((slot-name (svref slot-names i))) 
     568            (let ((slot-name (elt slot-names i))) 
    539569              (multiple-value-bind (value imm?) 
    540570                                   (if (slot-boundp object slot-name) 
     
    547577; and do something else as well. 
    548578 
    549 (defmacro sd-slots (sd) 
    550   `(ccl::%svref ,sd 1)) 
    551  
    552579(defmethod instance-slot-names ((instance structure-object)) 
    553   (let ((sd (gethash (car (ccl::%svref instance 0)) ccl::%defstructs%)) 
     580  #+ccl 
     581  (let ((sd (gethash (car (%svref instance 0)) ccl::%defstructs%)) 
    554582        (res nil)) 
    555     (dolist (slot (sd-slots sd)) 
     583    (dolist (slot (%svref sd 1)) ;; sd-slots 
    556584      (let ((name (car slot))) 
    557585        (when (symbolp name) 
    558586          (push name res)))) 
    559     (nreverse res))) 
     587    (nreverse res)) 
     588  #+LispWorks 
     589  (structure:structure-class-slot-names (class-of instance))) 
    560590 
    561591(defmethod instance-slot-names ((instance standard-object)) 
     
    573603                     (if (slot-boundp object slot) 
    574604                       (slot-value object slot) 
    575                        (ccl::%unbound-marker-8)))) 
     605                       (%unbound-marker)))) 
    576606         (slot-values (mapcar mapper slot-names))) 
    577607    (declare (dynamic-extent mapper)) 
    578608    (values `(allocate-instance-of-class ,(class-name (class-of object))) 
    579609            (when slot-names 
    580               `(ccl::%set-slot-values ,slot-names ,slot-values))))) 
     610              `(%set-slot-values ,object ,slot-names ,slot-values))))) 
    581611 
    582612(defun allocate-instance-of-class (class-name) 
     
    624654                              disk-cache pointer class pheap t) 
    625655          (dotimes (i (length slot-names)) 
    626             (let ((slot-name (svref slot-names i))) 
     656            (let ((slot-name (elt slot-names i))) 
    627657              (when (or (null real-slot-names) (position slot-name real-slot-names)) 
    628658                (multiple-value-bind (pointer immediate?) 
     
    648678    instance)) 
    649679 
     680 
    650681; These methods allow users to specialize the way that CLOS instances are saved. 
    651682 
     
    716747      (mapc #'require-symbol accessors)) 
    717748    (when class 
    718       (let* ((class-slots (mapcar 'slot-definition-name (ccl:class-instance-slots class)))) 
     749      (let* ((class-slots (mapcar 'slot-definition-name (class-instance-slots class)))) 
    719750        (flet ((require-slot (slot) 
    720751                 (unless (member slot class-slots :test 'eq) 
     
    738769         ',slots) 
    739770       (record-source-file ',class-name :disk-resident-slots) 
    740        ',class-name)))                   
     771       ',class-name))) 
    741772 
    742773 
  • lw-branch/persistent-heap.lisp

    r3 r6  
    66;; Code to maintain a Lisp heap in a file. 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2122;; Modification History 
    2223;; 
     24;; 02/01/06 gz   LispWorks port 
    2325;; 11/02/97 akh  bill's dc-aref-vector-and-index 
    2426;; 10/28/97 akh  bill's patches for multi-dim array and always rehash 
     
    188190;; 3) Don't worry about being able to walk memory. 
    189191 
    190 (defpackage :wood) 
    191192(in-package :wood) 
    192193 
    193194(export '(create-pheap open-pheap close-pheap with-open-pheap 
    194195          root-object p-load p-store 
     196          close-all-pheaps 
    195197          )) 
    196198 
    197199(eval-when (:compile-toplevel :execute) 
    198200  (require :woodequ) 
    199   (require :lispequ)) 
     201  #+ccl (require :lispequ)) 
    200202 
    201203; Dispatch tables at end of file 
    202204(declaim (special *p-load-subtype-functions* 
    203205                  *subtype->bytes-per-element* 
     206                  #+LispWorks *subtype->array-byte-offset* 
    204207                  *p-store-subtype-functions* 
    205208                  *subtype->uvreffer* 
    206209                  *subtype->uvsetter* 
    207                   *subtype-initial-element*)) 
     210                  *subtype-initial-element* 
     211                  #+LispWorks *subtype->array-element-type*)) 
    208212 
    209213(defparameter *pheap<->mem-hash-table-size* 500) 
     
    213217   (consing-area :accessor pheap-consing-area :initarg :consing-area) 
    214218   (pptr-hash :reader pptr-hash 
    215               :initform (make-hash-table :weak :value :test 'eql)) 
     219              :initform (make-hash :weak :value :test 'eql)) 
    216220   (wrapper-hash :reader wrapper-hash 
    217                  :initform (make-hash-table :weak :key :test 'eq)) 
     221                 :initform (make-hash :weak :key :test 'eq)) 
    218222   (pheap->mem-hash :reader pheap->mem-hash 
    219                    :initform (make-hash-table :weak :value 
    220                                               :test 'eql 
    221                                               :size *pheap<->mem-hash-table-size*)) 
     223                   :initform (make-hash :weak :value 
     224                                        :test 'eql 
     225                                        :size *pheap<->mem-hash-table-size*)) 
    222226   (mem->pheap-hash :reader mem->pheap-hash 
    223                    :initform (make-hash-table :weak :key 
    224                                               :test 'eq 
    225                                               :size *pheap<->mem-hash-table-size*)) 
     227                   :initform (make-hash :weak :key 
     228                                        :test 'eq 
     229                                        :size *pheap<->mem-hash-table-size*)) 
    226230   (p-load-hash :reader p-load-hash 
    227                 :initform (make-hash-table :weak :key :test 'eq)) 
     231                :initform (make-hash :weak :key :test 'eq)) 
    228232   (inside-p-load :accessor inside-p-load :initform nil) 
    229233   (p-store-hash :reader p-store-hash 
    230                  :initform (make-hash-table :weak :key :test 'eq)) 
     234                 :initform (make-hash :weak :key :test 'eq)) 
    231235   (inside-p-store :accessor inside-p-store :initform nil))) 
    232236 
     
    258262  (write-string "#.(" stream) 
    259263  (prin1 'pptr stream) 
    260   (tyo #\space stream) 
    261   (prin1 (pptr-pheap pptr) stream) 
     264  (write-char #\space stream) 
     265  ;; (prin1 (pptr-pheap pptr) stream) 
     266  (prin1 (pathname-name (pheap-stream (pptr-pheap pptr))) stream) 
    262267  (write-string " #x" stream) 
    263268  (let ((*print-base* 16)) 
    264269    (prin1 (pptr-pointer pptr) stream)) 
    265   (tyo #\) stream)) 
     270  (write-char #\) stream)) 
    266271 
    267272(defun pptr (pheap pointer) 
     
    293298(defparameter *default-area-segment-size* 4096) 
    294299 
    295 ;;;;;;;;;;;;;;;;;;;;;;; 
    296 ;;; 
    297 ;;; WITH-EGC macro can disable EGC while dumping or loading. 
    298 ;;; This prevents extraneous rehashing of the mem->pheap hash table 
    299 ;;; 
    300  
    301 (defmacro with-egc (state &body body) 
    302   (let ((egc-state (gensym))) 
    303     `(let ((,egc-state (ccl:egc-enabled-p))) 
    304        (unwind-protect 
    305          (progn 
    306            (ccl:egc ,state) 
    307            ,@body) 
    308          (ccl:egc ,egc-state))))) 
    309300;;;;;;;;;;;;;;;;;;;;;;;;;; 
    310301;; 
     
    330321                              (area-segment-size *default-area-segment-size*) 
    331322                              (page-size *default-page-size*) 
    332                               (mac-file-creator :ccl2) 
    333                               (external-format :WOOD)) 
     323                              #+ccl (mac-file-creator :ccl2) 
     324                              #+ccl (external-format :WOOD)) 
    334325  (let ((min-page-size 512)) 
    335326    (setq page-size  
     
    341332                      :if-does-not-exist :create 
    342333                      :page-size page-size 
    343                       :mac-file-creator mac-file-creator 
    344                       :external-format external-format))) 
     334                      #+ccl :mac-file-creator #+ccl mac-file-creator 
     335                      #+ccl :external-format #+ccl external-format))) 
    345336    (fill-long disk-cache 0 0 (ash (disk-cache-page-size disk-cache) -2)) 
    346337    (initialize-vector-storage 
     
    354345      ($pheap.page-size t) page-size) 
    355346    (setf (read-string disk-cache 
    356                        (+ $root-vector (- $t_vector) (ash $pheap-header-size 2))) 
     347                       (+ $root-vector (- $t_vector) (ash $pheap-header-size 2)) 
     348                       nil) 
    357349          #.(format nil "~%This is a persistent heap~%~ 
    358                          created by William's Object Oriented Database~%~ 
    359                          in Macintosh Common Lisp.~%")) 
     350                           created by William's Object Oriented Database~%~ 
     351                           in Macintosh Common Lisp.~%")) 
    360352    (close-disk-cache disk-cache) 
    361353    filename)) 
    362354 
    363355(defvar *open-pheaps* nil) 
     356 
     357(defun opened-pheap (path) 
     358  (let ((real-path (probe-file path))) 
     359    (and real-path 
     360         (dolist (p *open-pheaps*) 
     361           (when (equalp real-path (pheap-pathname p)) 
     362             (return p)))))) 
     363 
     364 
     365(defun close-all-pheaps () 
     366  (loop while *open-pheaps* 
     367        do (close-pheap (car *open-pheaps*)))) 
    364368 
    365369(defparameter *open-pheap-keywords* 
     
    373377    :shared-buffer 
    374378    :shared-buffer-pool 
    375     :mac-file-creator 
    376     :external-format 
     379    #+ccl :mac-file-creator 
     380    #+ccl :external-format 
    377381    :pheap-class 
    378382    :initial-transaction-p)) 
     
    389393                              shared-buffer 
    390394                              shared-buffer-pool 
    391                               (mac-file-creator :ccl2) 
    392                               (external-format :WOOD) 
     395                              #+ccl (mac-file-creator :ccl2) 
     396                              #+ccl (external-format :WOOD) 
    393397                              (pheap-class (load-time-value (find-class 'pheap))) 
    394398                              (initial-transaction-p t) 
     
    412416                                        :shared-buffer-pool shared-buffer-pool 
    413417                                        :write-hook 'pheap-write-hook 
    414                                         :mac-file-creator mac-file-creator 
    415                                         :external-format external-format 
     418                                        #+ccl :mac-file-creator #+ccl mac-file-creator 
     419                                        #+ccl :external-format #+ccl external-format 
    416420                                        :initial-transaction-p initial-transaction-p)))) 
    417421    (when (null disk-cache) 
     
    423427                        :area-segment-size area-segment-size 
    424428                        :page-size page-size 
    425                         :mac-file-creator mac-file-creator 
    426                         :external-format external-format) 
     429                        #+ccl :mac-file-creator #+ccl mac-file-creator 
     430                        #+ccl :external-format #+ccl external-format) 
    427431          (return-from open-pheap 
    428432            (apply #'open-pheap filename :if-exists :overwrite rest))) 
     
    481485         (page-size (dc-%svref disk-cache $root-vector $pheap.page-size)) 
    482486         (shared-buffer (disk-cache-shared-buffer disk-cache)) 
    483          (mac-file-creator (mac-file-creator old-filename)) 
    484          (external-format (mac-file-type old-filename))) 
     487         #+ccl (mac-file-creator (mac-file-creator old-filename)) 
     488         #+ccl (external-format (mac-file-type old-filename))) 
    485489    (flet ((open-it (pathname) 
    486490             (setf (pheap-disk-cache pheap) 
     
    490494                                    :shared-buffer shared-buffer 
    491495                                    :write-hook 'pheap-write-hook 
    492                                     :mac-file-creator mac-file-creator 
    493                                     :external-format external-format)) 
     496                                    #+ccl :mac-file-creator #+ccl mac-file-creator 
     497                                    #+ccl :external-format #+ccl external-format)) 
    494498             (push pheap *open-pheaps*))) 
    495499      (declare (dynamic-extent #'open-it)) 
     
    568572          (setq *open-disk-caches* 
    569573                (delq (pheap-disk-cache pheap) *open-disk-caches*)) 
    570           (setq ccl::*open-file-streams* 
    571                 (delq (pheap-stream pheap) ccl::*open-file-streams*))))))) 
    572  
    573 (pushnew 'flush-all-open-pheaps *lisp-cleanup-functions*) 
     574          #+ccl(setq ccl::*open-file-streams* 
     575                     (delq (pheap-stream pheap) ccl::*open-file-streams*)) 
     576          #-ccl(ignore-errors (close (pheap-stream pheap) :abort t))))))) 
     577 
     578(register-lisp-cleanup-function 'flush-all-open-pheaps) 
    574579 
    575580(defmacro with-transaction ((pheap) &body body) 
     
    627632         (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook))))) 
    628633 
    629 (defun dc-page-write-count (disk-cache) 
     634(defun dc-page-write-count (disk-cache #+LispWorks &optional #+LispWorks ignore) 
     635  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
    630636  (dc-%svref disk-cache $root-vector $pheap.page-write-count)) 
    631637 
     
    682688      (pptr pheap pointer)))) 
    683689 
    684 (defun dc-root-object (disk-cache) 
    685   (dc-%svref disk-cache $root-vector $pheap.root))                           
     690(defun dc-root-object (disk-cache #+LispWorks &optional #+LispWorks ignore) 
     691  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
     692  (dc-%svref disk-cache $root-vector $pheap.root)) 
    686693 
    687694(defvar *loading-pheap* nil) 
     
    717724    (declare (fixnum tag)) 
    718725    (let ((f (locally (declare (optimize (speed 3) (safety 0))) 
    719                (svref #(p-load-immediate        ; $t_fixnum 
    720                         p-load-vector   ; $t_vector 
    721                         p-load-symbol   ; $t_symbol 
    722                         p-load-dfloat   ; $t_dfloat 
    723                         p-load-cons     ; $t_cons 
    724                         p-load-immediate        ; $t_sfloat 
    725                         p-load-lfun     ; $t_lfun 
    726                         p-load-immediate)       ; $t_imm 
     726               (svref #+ccl (tag-vector :fixnum p-load-immediate  ; $t_fixnum 
     727                                        :vector p-load-vector     ; $t_vector 
     728                                        :symbol p-load-symbol     ; $t_symbol 
     729                                        :dfloat p-load-dfloat     ; $t_dfloat 
     730                                        :cons   p-load-cons       ; $t_cons 
     731                                        :sfloat p-load-immediate  ; $t_sfloat 
     732                                        :lfun   p-load-lfun       ; $t_lfun 
     733                                        :imm    p-load-immediate) ; $t_imm 
     734                      #+LispWorks (tag-vector :pos-fixnum p-load-immediate 
     735                                              :neg-fixnum p-load-immediate 
     736                                              :vector     p-load-vector 
     737                                              :symbol     p-load-symbol 
     738                                              :dfloat     p-load-dfloat 
     739                                              :cons       p-load-cons 
     740                                              :char       p-load-immediate 
     741                                              :imm        p-load-immediate) 
    727742                      tag)))) 
    728743      (unless (or (eq depth t) (eq f 'p-load-immediate)) 
     
    835850)  ; end of #+ppc-target progn 
    836851   
     852(defun uvector-subtype (object) 
     853  #+ccl `(and (ccl::uvectorp object) (ccl->wood-subtype (ccl::%vect-subtype object))) 
     854  #-ccl 
     855  (and (arrayp object) 
     856       (let ((type (array-element-type object))) 
     857         (cond ((eq type 'base-char) $v_sstr) 
     858               ((eq type 'simple-char) $v_xstr) 
     859               ((eq type 'double-float) $v_floatv) 
     860               ((eq type 't) $v_genv) 
     861               (t (case (and (consp type) (car type)) 
     862                    (unsigned-byte 
     863                     (let ((size (cadr type))) 
     864                       (cond ((eql size 8) $v_ubytev) 
     865                             ((eql size 16) $v_uwordv) 
     866                             ((eql size 32) $v_ulongv) 
     867                             ((eql size 1) $v_bitv)))) 
     868                    (signed-byte 
     869                     (let ((size (cadr type))) 
     870                       (cond ((eql size 8) $v_sbytev) 
     871                             ((eql size 16) $v_swordv) 
     872                             ((eql size 32) $v_slongv)))))))))) 
     873 
     874(defun-inline make-typed-ivector (length wood-subtype) 
     875  #+ccl (ccl::make-uvector length (wood->ccl-subtype wood-subtype)) 
     876  ;; TODO: make a table, better yet, make a p-load-xxx-vector for each one? 
     877  #-ccl 
     878  (cond ((eq wood-subtype $v_ubytev) (make-array length :element-type '(unsigned-byte 8))) 
     879        ((eq wood-subtype $v_uwordv) (make-array length :element-type '(unsigned-byte 16))) 
     880        ((eq wood-subtype $v_ulongv) (make-array length :element-type '(unsigned-byte 32))) 
     881        ((eq wood-subtype $v_floatv) (make-array length :element-type 'double-float)) 
     882        ((eq wood-subtype $v_sbytev) (make-array length :element-type '(signed-byte 8))) 
     883        ((eq wood-subtype $v_swordv) (make-array length :element-type '(signed-byte 16))) 
     884        ((eq wood-subtype $v_slongv) (make-array length :element-type '(signed-byte 32))) 
     885        ((eq wood-subtype $v_sstr)  (make-string length :element-type 'base-char)) 
     886        ((eq wood-subtype $v_xstr)  (make-string length :element-type 'simple-char)))) 
     887 
     888 
     889(defun-inline uvectorp (object) 
     890  #+ccl (ccl::uvectorp object) 
     891  #-ccl (and (uvector-subtype object) t)) 
     892 
     893(defun-inline %vect-subtype (vect) 
     894  #+ccl (ccl::%vect-subtype vect) 
     895  #-ccl (error "vect-subtype not implemented: ~s" vect)) 
     896 
    837897 
    838898(defstruct uninitialize-structure) 
     
    840900(defvar *uninitialized-structure* 
    841901  (make-uninitialize-structure)) 
     902 
     903(defun-inline make-typed-gvector (length wood-subtype) 
     904  #+ccl (ccl::make-uvector length (wood->ccl-subtype wood-subtype)) 
     905  #-ccl (ecase wood-subtype 
     906          (#.$v_genv (make-array length)))) 
    842907 
    843908; general vector 
    844909(defun p-load-gvector (pheap disk-cache pointer depth subtype &optional 
    845910                             special-index-p special-index-value struct-p) 
     911  #-ccl (assert (and (eql subtype $v_genv) (not special-index-p) (not struct-p))) 
    846912  (let* (length 
    847913         modified? 
     
    853919                           (and (fixnump depth) (< depth length))) 
    854920                     (return-from p-load-gvector (pptr pheap pointer)) 
    855                      (let ((res (ccl::make-uvector 
    856                                  length (wood->ccl-subtype subtype)))) 
     921                     (let ((res (make-typed-gvector length subtype))) 
    857922                       (when struct-p 
    858923                         ; Make sure it looks like a structure 
     
    882947    (values vector modified?))) 
    883948 
     949#+ccl 
    884950(defun p-load-header (pheap disk-cache pointer depth subtype &optional 
    885951                            special-index-p special-index-value) 
     
    893959                      special-index-p special-index-value)))) 
    894960 
    895 #-ppc-target 
     961#+ccl-68k-target 
    896962(defun p-load-arrayh (pheap disk-cache pointer depth subtype) 
    897963  (p-load-header pheap disk-cache pointer depth subtype)) 
     
    9421008 
    9431009 
     1010#+LispWorks 
     1011(defun p-load-arrayh (pheap disk-cache pointer depth subtype) 
     1012  (let* ((cached? t) 
     1013         (bits (dc-%arrayh-bits disk-cache pointer)) 
     1014         (fillp (logbitp $arh_fill_bit bits)) 
     1015         (adjustablep (logbitp $arh_adjp_bit bits)) 
     1016         (displacedp (logbitp $arh_disp_bit bits)) 
     1017         (subtag (dc-%arrayh-type disk-cache pointer)) 
     1018         (etype (if (eql subtag $v_badptr) 
     1019                  (dc-%svref-value pheap disk-cache pointer $arh.etype) 
     1020                  (svref *subtype->array-element-type* subtag))) 
     1021         (rank (dc-array-rank disk-cache pointer)) 
     1022         (dims (if (eql rank 1) 
     1023                 (dc-%svref-fixnum disk-cache pointer $arh.vlen '$arh.vlen) 
     1024                 (loop for i from 0 below rank 
     1025                       collect (dc-%svref-fixnum disk-cache pointer (+ $arh.fill i))))) 
     1026         (array (maybe-cached-value pheap pointer 
     1027                   (setq cached? nil) 
     1028                   (if displacedp 
     1029                     (make-array 0 :displaced-to #() 
     1030                                 :adjustable adjustablep :fill-pointer fillp 
     1031                                 :element-type etype) 
     1032                     (make-array dims 
     1033                                 :adjustable adjustablep :fill-pointer fillp 
     1034                                 :element-type etype))))) 
     1035    (when cached? 
     1036      (unless (and (equal (array-element-type array) etype) 
     1037                   (eq displacedp (and (displaced-array-p array) t)) 
     1038                   (eq adjustablep (and (adjustable-array-p array) t)) 
     1039                   (eq fillp (and (array-has-fill-pointer-p array) t))) 
     1040        (error "Incompatible array ~s" array))) 
     1041    (when (or (not cached?) 
     1042              (and (eq depth t) 
     1043                   (let ((p-load-hash (p-load-hash pheap))) 
     1044                     (unless (gethash array p-load-hash) 
     1045                       (setf (gethash array p-load-hash) array))))) 
     1046      (ecase subtype 
     1047        (#.$v_arrayh 
     1048         (let* ((displaced-to (pointer-load pheap (dc-%svref disk-cache pointer $arh.vect) 
     1049                                            depth disk-cache)) 
     1050                (displaced-offset (dc-%svref-fixnum disk-cache pointer $arh.offs '$arh.offs)) 
     1051                (adjusted-array (adjust-array array dims 
     1052                                              :displaced-to displaced-to 
     1053                                              :displaced-index-offset displaced-offset))) 
     1054           (unless (eq adjusted-array array) 
     1055             (error "Couldn't readjust array ~s" array)))) 
     1056        (#.$v_garrayh 
     1057         (let* ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil) 
     1058                                        ((listp depth) (car depth)) 
     1059                                        (t depth))) 
     1060                ($arh.data (%arrayh-overhead array)) 
     1061                (total-size (array-total-size array))) 
     1062           (dotimes (i total-size) 
     1063             (setf (row-major-aref array i) 
     1064                   (multiple-value-bind (value imm?) 
     1065                       (dc-%svref disk-cache pointer (+ $arh.data i)) 
     1066                     (if imm? 
     1067                       value 
     1068                       (pointer-load pheap value next-level-depth disk-cache))))))) 
     1069        (#.$v_iarrayh 
     1070         (let* ((overhead-bytes (* 4 (%arrayh-overhead array))) 
     1071                (num-bytes (dc-%vector-size disk-cache pointer))) 
     1072           (load-bytes-to-iarray disk-cache 
     1073                                 (addr+ disk-cache pointer (- overhead-bytes $t_vector)) 
     1074                                 (- num-bytes overhead-bytes) 
     1075                                 array)))) 
     1076      (when fillp 
     1077        (setf (fill-pointer array) (dc-%svref-fixnum disk-cache pointer $arh.fill '$arh.fill)))) 
     1078    array)) 
     1079 
     1080#+ccl 
    9441081(defun p-load-istruct (pheap disk-cache pointer depth subtype) 
    9451082  (when (or (eq depth :single) (fixnump depth)) 
     
    9511088    vector)) 
    9521089 
     1090#+ccl 
    9531091(defun p-load-struct (pheap disk-cache pointer depth subtype) 
    9541092  (let ((vector (p-load-gvector pheap disk-cache pointer depth subtype nil nil t))) 
     
    9581096          (setf (uvref vector 0) (p-load struct-type))))) 
    9591097    vector)) 
     1098 
     1099#+LispWorks 
     1100(defun p-store-struct (pheap object descend disk-cache address length) 
     1101  (assert (eql length (uvsize object))) 
     1102  (dotimes (i length) 
     1103    (let ((value (if (eql i 0) (class-of object) (%%svref object i)))) 
     1104      (multiple-value-bind (element imm?) (%p-store pheap value descend) 
     1105        (setf (dc-%svref disk-cache address i imm?) element))))) 
     1106 
     1107#+LispWorks 
     1108(defun p-load-struct (pheap disk-cache pointer depth subtype) 
     1109  (declare (ignore subtype)) 
     1110  (let* (modified? 
     1111         (cached? t) 
     1112         (struct (maybe-cached-value pheap pointer 
     1113                   (when (or (null depth) 
     1114                             (and (fixnump depth) 
     1115                                  (< depth (dc-%simple-vector-length disk-cache pointer)))) 
     1116                     (return-from p-load-struct (pptr pheap pointer))) 
     1117                   (setq cached? nil) 
     1118                   (let* ((class (multiple-value-bind (cpointer imm?) 
     1119                                     (dc-%svref disk-cache pointer 0) 
     1120                                   (and (not imm?) (pointer-load pheap cpointer :default disk-cache)))) 
     1121                          (res (allocate-instance class))) 
     1122                     res)))) 
     1123    (when (or (not cached?) 
     1124              (listp depth) 
     1125              (and (eq depth t) 
     1126                   (let ((p-load-hash (p-load-hash pheap))) 
     1127                     (unless (gethash struct p-load-hash) 
     1128                       (setf (gethash struct p-load-hash) struct))))) 
     1129      (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil) 
     1130                                     ((listp depth) (car depth)) 
     1131                                     (t depth)))) 
     1132        (setq modified? t) 
     1133        (loop for i from 1 below (min (uvsize struct) (dc-%simple-vector-length disk-cache pointer)) 
     1134              do (setf (uvref struct i) 
     1135                       (multiple-value-bind (pointer immediate?) 
     1136                           (dc-%svref disk-cache pointer i) 
     1137                         (if immediate? 
     1138                           pointer 
     1139                           (pointer-load pheap pointer next-level-depth disk-cache))))))) 
     1140    (values struct modified?))) 
     1141 
     1142 
    9601143 
    9611144; ivectors 
     
    9691152                  (if (and depth 
    9701153                           (or (not (fixnump depth)) (<= length depth))) 
    971                     (load-byte-array 
     1154                    (load-bytes-to-ivector 
    9721155                     disk-cache (addr+ disk-cache pointer $v_data) size 
    973                      (ccl::make-uvector length (wood->ccl-subtype subtype)) 
    974                      0 t) 
     1156                     (make-typed-ivector length subtype)) 
    9751157                    (return-from p-load-ivector (pptr pheap pointer))))))) 
    9761158    (when (and cached? (eq depth t)) 
     
    9791161        (unless (eql (uvsize res) (dc-uvsize disk-cache pointer)) 
    9801162          (error "Inconsistency. Disk ivector is different size than in-memory version.")) 
    981         (unless (eql (wood->ccl-subtype subtype) 
    982                      (ccl::%vect-subtype res)) 
     1163        (unless (eql subtype (uvector-subtype res)) 
    9831164          (error "Inconsistency. Subtype mismatch.")) 
    984         (load-byte-array disk-cache (addr+ disk-cache pointer $v_data) size res 0 t))) 
     1165        (load-bytes-to-ivector disk-cache (addr+ disk-cache pointer $v_data) size res))) 
    9851166    res)) 
    9861167 
    987 #-ppc-target 
     1168#+ccl-68k-target 
    9881169(defun p-load-bignum (pheap disk-cache pointer depth subtype) 
    9891170  (p-load-ivector pheap disk-cache pointer depth subtype)) 
     
    9941175;; other words are the magnitude. 
    9951176;; Some day, recode this using bignum internals so that it doesn't cons so much. 
    996 #+ppc-target 
     1177#-ccl-68k-target 
    9971178(defun p-load-bignum (pheap disk-cache pointer depth subtype) 
    9981179  (declare (ignore pheap depth subtype)) 
     
    10101191          value))))) 
    10111192 
    1012 #+ppc-target 
     1193#-ccl-68k-target 
    10131194(defun p-load-bit-vector (pheap disk-cache pointer depth subtype) 
    1014   (declare (fixnum subtype)) 
     1195  (declare (ignore subtype)) 
    10151196  (let* ((cached? t) 
    10161197         (res (maybe-cached-value pheap pointer 
    10171198                (setq cached? nil) 
    1018                 (let ((length (dc-uvsize disk-cache pointer)) 
    1019                       (size (dc-%vector-size disk-cache pointer))) 
    1020                   (declare (fixnum size)) 
    1021                   (load-byte-array 
     1199                (let ((length (dc-uvsize disk-cache pointer)) ; length in bits 
     1200                      (size (dc-%vector-size disk-cache pointer))) ; size in bytes 
     1201                  #-LispWorks(declare (fixnum size)) 
     1202                  (load-bytes-to-bit-vector 
    10221203                   disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) 
    1023                    (ccl::make-uvector length (wood->ccl-subtype subtype)) 
    1024                    0 t))))) 
     1204                   #-ccl (make-array length :element-type 'bit) 
     1205                   #+ccl (ccl::make-uvector length (wood->ccl-subtype subtype))))))) 
    10251206    (when (and cached? (eq depth t)) 
    10261207      (let* ((size (dc-%vector-size disk-cache pointer)) 
    10271208             (subtype (dc-%vector-subtype disk-cache pointer))) 
    1028         (declare (fixnum size)) 
     1209        #-LispWorks(declare (fixnum size)) 
    10291210        (unless (eql (uvsize res) (dc-uvsize disk-cache pointer)) 
    10301211          (error "Inconsistency. Disk ivector is different size than in-memory version.")) 
    1031         (unless (eql (wood->ccl-subtype subtype) 
    1032                      (ccl::%vect-subtype res)) 
     1212        (unless (eql subtype (uvector-subtype res)) 
    10331213          (error "Inconsistency. Subtype mismatch.")) 
    1034         (load-byte-array disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) res 0 t))) 
     1214        (load-bytes-to-bit-vector disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) res))) 
    10351215    res)) 
    10361216 
     
    10721252 
    10731253(defun p-load-cons (pheap disk-cache pointer depth) 
    1074     (p-load-cons-internal pheap disk-cache pointer depth nil nil)) 
     1254  (p-load-cons-internal pheap disk-cache pointer depth nil nil)) 
    10751255 
    10761256(defvar *avoid-cons-caching* nil) 
     
    11221302; All this hair is to create the lfun before loading its immediates. 
    11231303; This allows circular references. 
     1304#+ccl 
    11241305(defun p-load-lfun (pheap disk-cache pointer depth) 
    11251306  (let (imms imms-address indices 
     
    11491330      (when imms 
    11501331        (dotimes (i imms-length) 
    1151           (multiple-value-bind (val imm?) (dc-%svref disk-cache imms-address i) 
    1152             (setf (ccl::%svref imms i) 
    1153                   (if imm? val (pointer-load-internal pheap val :default disk-cache))))) 
     1332          (setf (ccl::%svref imms i) (dc-%svref-value pheap disk-cache imms-address i))) 
    11541333        (ccl::%patch-lfun-immediates lfun imms indices)) 
    11551334      lfun))) 
     
    12751454 
    12761455#+ppc-target 
    1277 (progn 
    1278  
    1279 (declaim (inline %ccl2-fixnum-p)) 
    1280  
    1281 (defun %ccl2-fixnum-p (ppc-fixnum) 
     1456(defun-inline %ccl2-fixnum-p (ppc-fixnum) 
    12821457  (declare (fixnum ppc-fixnum)) 
    12831458  (and (>= ppc-fixnum (- (ash 1 28))) (< ppc-fixnum (ash 1 28)))) 
    12841459 
    1285 ) 
    1286  
    1287 (declaim (inline immediate-object-p)) 
    1288  
    1289 (defun immediate-object-p (object) 
    1290   #-ppc-target 
     1460 
     1461(defun-inline immediate-object-p (object) 
     1462  #+ccl-68k-target 
    12911463  (ccl::dtagp object (+ (ash 1 ccl::$t_fixnum)  
    12921464                        (ash 1 ccl::$t_sfloat) 
     
    12961468    (if (eql typecode ppc::tag-fixnum) 
    12971469      (%ccl2-fixnum-p object) 
    1298       (eql typecode ppc::tag-imm)))) 
     1470      (eql typecode ppc::tag-imm))) 
     1471  #+LispWorks ;; see %%store-pointer 
     1472  (or (fixnump object) 
     1473      (characterp object) 
     1474      (eq object (%unbound-marker)))) 
    12991475 
    13001476; Same comment here as for pointer-load: 
     
    13321508                                    &body body 
    13331509                                    &environment env) 
    1334   (multiple-value-bind (body decls) (ccl::parse-body body env) 
     1510  (multiple-value-bind (body decls) (parse-body body env) 
    13351511    (unless (null (cddr body)) 
    13361512      (error "body must be of the form (conser filler)")) 
     
    13401516          (filler-var (gensym))) 
    13411517      `(let ((,conser-var #'(lambda (,disk-cache ,object) 
    1342                               (declare (ignore-if-unused ,object)) 
     1518                              (declare (ignorable ,object)) 
    13431519                              ,@decls 
    13441520                              ,conser)) 
    13451521             (,filler-var #'(lambda (,pheap ,disk-cache ,object ,address ,descend) 
    1346                               (declare (ignore-if-unused ,pheap ,descend)) 
     1522                              (declare (ignorable ,pheap ,descend)) 
    13471523                              ,@decls 
    13481524                              ,filler))) 
     
    13851561                                                          &body body 
    13861562                                                          &environment env) 
    1387   (multiple-value-bind (body decls) (ccl::parse-body body env) 
     1563  (multiple-value-bind (body decls) (parse-body body env) 
    13881564    (destructuring-bind (conser filler) body 
    13891565      (let ((conser-var (gensym)) 
     
    14901666(defvar *preserve-lfun-info* nil) 
    14911667 
     1668#+ccl 
    14921669(defmethod %p-store-object (pheap (object function) descend) 
    14931670  (let* ((split-vec (apply #'vector (split-lfun object *preserve-lfun-info*))) 
     
    15141691      (let* ((inner-cached? t)) 
    15151692        (setq address (%p-store-object-body (pheap cdr descend disk-cache address) 
    1516                         (declare (ignore-if-unused cdr disk-cache address)) 
     1693                        (declare (ignorable cdr disk-cache address)) 
    15171694                        (dc-cons disk-cache $pheap-nil $pheap-nil) 
    15181695                        (setq inner-cached? nil)) 
    1519               cached? inner-cached?))               
     1696              cached? inner-cached?)) 
    15201697      (setf (dc-cdr disk-cache outer-address) address) 
    15211698      (unless cached? 
     
    15421719 
    15431720(defun dc-cons-float (disk-cache value &optional area) 
    1544   (setq value (require-type value 'float)) 
     1721  (setq value (require-type value 'double-float)) 
    15451722  (let ((address (%allocate-storage disk-cache area 8))) 
    15461723    (setf (read-double-float disk-cache (decf address $t_cons)) value) 
     
    15791756 
    15801757 
    1581 #-ppc-target 
     1758#+ccl-68k-target 
    15821759(defmethod %p-store-object (pheap (object t) descend) 
    1583   (if (uvectorp object) 
     1760  (if (ccl::uvectorp object) 
    15841761    (if (ccl::%lfun-vector-p object) 
    15851762      (%p-store-lfun-vector pheap object descend) 
     
    15901767; No lfun vectors on the PPC 
    15911768(defmethod %p-store-object (pheap (object t) descend) 
    1592   (if (uvectorp object) 
     1769  (if (ccl::uvectorp object) 
    15931770    (%p-store-uvector pheap object descend) 
    15941771    (error "Don't know how to store ~s" object))) 
    15951772 
    1596 #+ppc-target 
    1597 ; Some ppc fixnums aren't Wood fixnums 
    1598 (defmethod %p-store-object (pheap (object fixnum) descend) 
    1599   (if (%ccl2-fixnum-p object) 
     1773#+LispWorks 
     1774(defmethod %p-store-object (pheap (object t) descend) 
     1775  (error "Don't know how to store ~s" object)) 
     1776 
     1777(defun %p-store-as-uvector (pheap object descend length subtype) 
     1778  (%p-store-object-body (pheap object descend disk-cache address) 
     1779    (dc-make-uvector disk-cache length subtype) 
     1780    (let ((store-function (or (svref *p-store-subtype-functions* subtype) 
     1781                              (error "Can't store vector of subtype ~s: ~s" subtype object)))) 
     1782      (funcall store-function pheap object descend disk-cache address length)))) 
     1783 
     1784#+CCL 
     1785(defun %p-store-uvector (pheap object descend) 
     1786  (%p-store-as-uvector pheap object descend 
     1787                       (uvsize object) 
     1788                       (uvector-subtype object))) 
     1789 
     1790 
     1791#-ccl-68k-target 
     1792(defmethod %p-store-object (pheap (object integer) descend) 
     1793  (if #+ccl (%ccl2-fixnum-p object) #+LispWorks (fixnump object) 
    16001794    (progn 
    16011795      ; We should only get here if %ccl2-fixnum-p is false. 
    16021796      (cerror "Do the right thing" "Object, ~s,  doesn't satisfy ~s" object '%ccl2-fixnum-p) 
    16031797      (values object t)) 
    1604     (p-store-bignum pheap object descend))) 
    1605          
    1606 (defun %p-store-uvector (pheap object descend) 
    1607   (let* ((length (uvsize object)) 
    1608          (subtype (ccl->wood-subtype (ccl::%vect-subtype object))) 
    1609          (store-function (or (svref *p-store-subtype-functions* subtype) 
    1610                              (error "Can't store vector of subtype ~s: ~s" subtype object)))) 
    1611     #+ppc-target 
    1612     (when (eql subtype $v_arrayh) 
    1613       (return-from %p-store-uvector 
    1614         (p-store-arrayh pheap object descend))) 
    1615     #+ppc-target 
    1616     (when (eql subtype $v_bignum) 
    1617       (p-store-bignum pheap object descend)) 
    1618     #+ccl-3 
    1619     (when (eql subtype $v_nhash) 
    1620       (return-from %p-store-uvector 
    1621         (p-store-nhash pheap object descend))) 
    1622     (%p-store-object-body (pheap object descend disk-cache address) 
    1623       (dc-make-uvector disk-cache length subtype) 
    1624       (funcall store-function pheap object descend disk-cache address length)))) 
    1625  
    1626 #+ppc-target 
    1627 (defun p-store-bignum (pheap object descend) 
     1798    (let ((words (1+ (floor (integer-length (abs object)) 16)))) 
     1799      (%p-store-as-uvector pheap object descend words $v_bignum)))) 
     1800 
     1801#-ccl-68k-target 
     1802(defun p-store-bignum (pheap object descend disk-cache address words) 
     1803  (declare (ignore pheap descend)) 
    16281804  (let* ((negative? (< object 0)) 
    16291805         (abs (if negative? (- object) object)) 
    1630          (bits (integer-length abs))) 
    1631     (multiple-value-bind (words zero-bits) (ceiling bits 16) 
    1632       (declare (fixnum words bits)) 
    1633       (when (eql 0 zero-bits) 
    1634         (incf words)) 
    1635       (%p-store-object-body (pheap object descend disk-cache address) 
    1636         (declare (ignore object)) 
    1637         (dc-make-uvector disk-cache words $v_bignum) 
    1638         (let ((position 0) 
    1639               (index (* 2 (1- words)))) 
    1640           (declare (fixnum index)) 
    1641           (accessing-disk-cache (disk-cache (+ address $v_data)) 
    1642             (dotimes (i words) 
    1643               (let ((word (if (> position bits) 0 (ccl::load-byte 16 position abs)))) 
    1644                 (declare (fixnum word)) 
    1645                 (when (and negative? (eql index 0)) 
    1646                   (setq word (logior #x8000 word))) 
    1647                 (store.w word index) 
    1648                 (incf position 16) 
    1649                 (decf index 2))))))))) 
     1806         (bits (integer-length abs)) 
     1807         (position 0) 
     1808         (index (* 2 (1- words)))) 
     1809    (declare (fixnum index)) 
     1810    (accessing-disk-cache (disk-cache (+ address $v_data)) 
     1811      (dotimes (i words) 
     1812        (let ((word (if (> position bits) 
     1813                      0 
     1814                      #+ccl (ccl::load-byte 16 position abs) 
     1815                      #-ccl (ldb (byte 16 position) abs)))) 
     1816          (declare (fixnum word)) 
     1817          (when (and negative? (eql index 0)) 
     1818            (setq word (logior #x8000 word))) 
     1819          (store.w word index) 
     1820          (incf position 16) 
     1821          (decf index 2)))))) 
     1822 
     1823#+LispWorks 
     1824(progn 
     1825 
     1826(defmethod %p-store-object (pheap (object ratio) descend) 
     1827  (%p-store-as-uvector pheap object descend 2 $v_ratio)) 
     1828 
     1829(defun p-store-ratio (pheap object descend disk-cache address length) 
     1830  (declare (ignore length)) 
     1831  (multiple-value-bind (element imm?) (%p-store pheap (numerator object) descend) 
     1832    (setf (dc-%svref disk-cache address 0 imm?) element)) 
     1833  (multiple-value-bind (element imm?) (%p-store pheap (denominator object) descend) 
     1834    (setf (dc-%svref disk-cache address 1 imm?) element))) 
     1835 
     1836(defun p-load-ratio (pheap disk-cache pointer depth subtype) 
     1837  (declare (ignore depth subtype)) 
     1838  (maybe-cached-value pheap pointer 
     1839    (let* ((num (dc-%svref-value pheap disk-cache pointer 0)) 
     1840           (den (dc-%svref-value pheap disk-cache pointer 1))) 
     1841      (/ num den)))) 
     1842 
     1843(defmethod %p-store-object (pheap (object complex) descend) 
     1844  (%p-store-as-uvector pheap object descend 2 $v_complex)) 
     1845 
     1846(defun p-store-complex (pheap object descend disk-cache address length) 
     1847  (declare (ignore length)) 
     1848  (multiple-value-bind (element imm?) (%p-store pheap (realpart object) descend) 
     1849    (setf (dc-%svref disk-cache address 0 imm?) element)) 
     1850  (multiple-value-bind (element imm?) (%p-store pheap (imagpart object) descend) 
     1851    (setf (dc-%svref disk-cache address 1 imm?) element))) 
     1852 
     1853(defun p-load-complex (pheap disk-cache pointer depth subtype) 
     1854  (declare (ignore depth subtype)) 
     1855  (maybe-cached-value pheap pointer 
     1856    (let* ((real (dc-%svref-value pheap disk-cache pointer 0)) 
     1857           (imag (dc-%svref-value pheap disk-cache pointer 1))) 
     1858      (complex real imag)))) 
     1859) 
     1860 
     1861;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
     1862(defun-inline %arrayh-overhead (object) 
     1863  (let* ((rank (array-rank object))) 
     1864    (if (eql rank 1)  
     1865      (+ $arh.fill 1) 
     1866      (+ $arh.dims rank 1)))) 
    16501867 
    16511868#+ppc-target 
    1652 (defun p-store-arrayh (pheap object descend) 
    1653   (assert (ccl::%array-is-header object)) 
    1654   (multiple-value-bind (displaced-to offset) (displaced-array-p object) 
    1655     (let* ((rank (array-rank object)) 
    1656            (dims (unless (eql rank 1) (array-dimensions object))) 
    1657            (total-size (array-total-size object)) 
    1658            (fill (and (eql rank 1) (array-has-fill-pointer-p object) (fill-pointer object))) 
    1659            (simple (ccl::simple-array-p object)) 
    1660            (subtype (old-wood->ccl-subtype (ccl->wood-subtype (ccl::%array-header-subtype object)))) 
    1661            (adjustable (adjustable-array-p object)) 
    1662            (length (if (eql rank 1)  
    1663                      (+ $arh.fill 1) 
    1664                      (+ $arh.dims rank 1))) 
    1665            (bits (+ (if fill (ash 1 $arh_fill_bit) 0) 
    1666                     (if simple (ash 1 $arh_simple_bit) 0) 
    1667                     (if (ccl::%array-is-header displaced-to) (ash 1 $arh_disp_bit) 0) 
    1668                     (if adjustable (ash 1 $arh_adjp_bit) 0))) 
    1669            (flags (+ (ash rank (+ 2 16 -3)) 
    1670                      (ash subtype (+ 8 -3)) 
    1671                      (ash bits -3)))) 
    1672       (unless (fixnump flags) 
    1673         (error "Array header flags not a fixnum. Rank must be too big.")) 
    1674       (unless displaced-to 
    1675         (error "~s should be displaced but isn't")) 
    1676       (%p-store-object-body (pheap object descend disk-cache address) 
    1677         (declare (ignore object)) 
    1678         (dc-make-uvector disk-cache length $v_arrayh) 
    1679         (progn 
    1680           (dc-%svfill disk-cache address 
    1681             ($arh.fixnum t) flags 
    1682             ($arh.offs t) offset) 
    1683           (if (eql rank 1) 
    1684             (dc-%svfill disk-cache address 
    1685               ($arh.vlen t) total-size 
    1686               ($arh.fill t) (or fill total-size)) 
    1687             (progn 
    1688               (setf (dc-%svref disk-cache address $arh.dims t) rank) 
    1689               (dotimes (i rank) 
    1690                 (setf (dc-%svref disk-cache address (+ $arh.fill i) t) 
    1691                       (pop dims))))) 
    1692           (setf (dc-%svref disk-cache address $arh.vect) 
    1693                 (%p-store pheap displaced-to descend))))))) 
     1869(defmethod %p-store-object (pheap (object array) descend) 
     1870  (if (ccl::%array-is-header object) 
     1871    (%p-store-as-uvector pheap object descend (%arrayh-overhead object) $v_arrayh) 
     1872    (%p-store-uvector pheap object descend))) 
     1873 
     1874#+LispWorks 
     1875(defmethod %p-store-object (pheap (object array) descend) 
     1876  (if (displaced-array-p object) 
     1877    (%p-store-as-uvector pheap object descend (%arrayh-overhead object) $v_arrayh) 
     1878    (let ((subtype (uvector-subtype object))) 
     1879      (if (and subtype (typep object 'simple-array) (vectorp object)) 
     1880        (%p-store-as-uvector pheap object descend (array-total-size object) subtype) 
     1881        (let* ((overhead (%arrayh-overhead object)) 
     1882               (num-elements (array-total-size object))) 
     1883          (if (or (null subtype) (eq subtype $v_genv)) 
     1884            (%p-store-as-uvector pheap object descend (+ overhead num-elements) $v_garrayh) 
     1885            (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)) 
     1886                   (data-bytes (ceiling (* num-elements bytes-per-element))) 
     1887                   (total-bytes (+ (* overhead 4) data-bytes))) 
     1888              (%p-store-as-uvector pheap object descend total-bytes $v_iarrayh)))))))) 
     1889 
     1890 
     1891(defun %store-array-header-slots (pheap disk-cache address object) 
     1892  (let* ((displaced-offset (or (nth-value 1 (displaced-array-p object)) 0)) 
     1893         (rank (array-rank object)) 
     1894         (dims (unless (eql rank 1) (array-dimensions object))) 
     1895         (total-size (array-total-size object)) 
     1896         (fill (and (eql rank 1) (array-has-fill-pointer-p object) (fill-pointer object))) 
     1897         #+ccl (simple (ccl::simple-array-p object)) 
     1898         (subtype #+ccl (old-wood->ccl-subtype (ccl->wood-subtype (ccl::%array-header-subtype object))) 
     1899                  #-ccl (or (uvector-subtype object) $v_badptr)) 
     1900         (adjustable (adjustable-array-p object)) 
     1901         (bits (+ (if fill (ash 1 $arh_fill_bit) 0) 
     1902                  #+ccl (if simple (ash 1 $arh_simple_bit) 0) 
     1903                  (if #+ccl (ccl::%array-is-header displaced-to) 
     1904                      #-ccl (displaced-array-p object) 
     1905                    (ash 1 $arh_disp_bit) 0) 
     1906                  (if adjustable (ash 1 $arh_adjp_bit) 0))) 
     1907         (flags (+ (ash rank (+ 2 16 -3)) 
     1908                   (ash (or subtype $v_badptr) (+ 8 -3)) 
     1909                   (ash bits -3)))) 
     1910    (unless (fixnump flags) 
     1911      (error "Array header flags not a fixnum. Rank must be too big.")) 
     1912    (dc-%svfill disk-cache address 
     1913      ($arh.fixnum t) flags 
     1914      ($arh.offs t) displaced-offset) 
     1915    (if (eql rank 1) 
     1916      (dc-%svfill disk-cache address 
     1917        ($arh.vlen t) total-size 
     1918        ($arh.fill t) (or fill total-size)) 
     1919      (progn 
     1920        (setf (dc-%svref disk-cache address $arh.dims t) rank) 
     1921        (dotimes (i rank) 
     1922          (setf (dc-%svref disk-cache address (+ $arh.fill i) t) 
     1923                (pop dims))))) 
     1924    #+LispWorks 
     1925    (when (eql subtype $v_badptr) 
     1926      (setf (dc-%svref disk-cache address $arh.etype) 
     1927            (%p-store pheap (array-element-type object) :default))))) 
     1928 
     1929#-ccl-68k-target 
     1930(defun p-store-arrayh (pheap object descend disk-cache address length) 
     1931  (declare (ignore length)) 
     1932  #+ccl (assert (ccl::%array-is-header object)) 
     1933  (%store-array-header-slots pheap disk-cache address object) 
     1934  (let ((displaced-to (displaced-array-p object))) 
     1935    (unless displaced-to 
     1936      (error "~s should be displaced but isn't" object)) 
     1937    (setf (dc-%svref disk-cache address $arh.vect) 
     1938          (%p-store pheap displaced-to descend)))) 
     1939 
     1940#+LispWorks 
     1941(defun p-store-garrayh (pheap object descend disk-cache address length) 
     1942  (%store-array-header-slots pheap disk-cache address object) 
     1943  (setf (dc-%svref disk-cache address $arh.vect) $pheap-nil) 
     1944  (let* (($arh.data (%arrayh-overhead object)) 
     1945         (total-size (array-total-size object))) 
     1946    (assert (eql (+ $arh.data total-size) length)) 
     1947    (dotimes (i total-size) 
     1948      (multiple-value-bind (element imm?) (%p-store pheap (row-major-aref object i) descend) 
     1949        (setf (dc-%svref disk-cache address (+ $arh.data i) imm?) element))))) 
     1950 
     1951#+LispWorks 
     1952(defun p-store-iarrayh (pheap object descend disk-cache address num-bytes) 
     1953  (declare (ignore descend)) 
     1954  (%store-array-header-slots pheap disk-cache address object) 
     1955  (setf (dc-%svref disk-cache address $arh.vect) $pheap-nil) 
     1956  (let* ((overhead-bytes (* 4 (%arrayh-overhead object)))) 
     1957    (store-bytes-from-iarray object disk-cache 
     1958                             (addr+ disk-cache address (- overhead-bytes $t_vector)) 
     1959                             (- num-bytes overhead-bytes)))) 
    16941960 
    16951961(defun p-store-gvector (pheap object descend disk-cache address length) 
     
    17011967  (declare (ignore pheap descend length)) 
    17021968  (let* ((bytes (dc-%vector-size disk-cache address))) 
    1703     (store-byte-array object disk-cache (addr+ disk-cache address $v_data) bytes 0 t))) 
    1704  
    1705 #+ppc-target 
     1969    (store-bytes-from-ivector object disk-cache (addr+ disk-cache address $v_data) bytes))) 
     1970 
     1971#-ccl-68k-target 
    17061972(defun p-store-bit-vector (pheap object descend disk-cache address length) 
    17071973    (declare (ignore pheap descend length)) 
    17081974    (let* ((bytes (dc-%vector-size disk-cache address))) 
    1709       (declare (fixnum bytes)) 
    1710       (store-byte-array object disk-cache (addr+ disk-cache address (1+ $v_data)) (1- bytes) 0 t))) 
    1711  
    1712 #-ppc-target 
     1975      #-LispWorks(declare (fixnum bytes)) 
     1976      (store-bytes-from-bit-vector object disk-cache (addr+ disk-cache address (1+ $v_data)) (1- bytes)))) 
     1977 
     1978#+ccl-68k-target 
    17131979(defun %p-store-lfun-vector (pheap object descend) 
    17141980  (%p-store-object-body (pheap object descend disk-cache address) 
     
    17191985       pheap disk-cache address load-function.args nil descend)))) 
    17201986 
     1987;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
     1988#+ccl 
    17211989(defmethod p-make-load-function-using-pheap ((pheap pheap) (hash hash-table)) 
    17221990  (let ((rehashF (function-name (ccl::nhash.rehashF hash))) 
     
    17362004                                ,vector ,count ,locked-additions))))) 
    17372005 
     2006#+ccl 
    17382007(defun %initialize-hash-table (hash rehashF keytransF compareF vector count locked-additions) 
    17392008  (flet ((convert (f) 
     
    17522021      (ccl::%maybe-rehash hash)))) 
    17532022 
    1754 #-ccl-3 
     2023#+(and ccl (not ccl-3)) 
    17552024(defun p-load-nhash (pheap disk-cache pointer depth subtype) 
    17562025  (p-load-header pheap disk-cache pointer depth subtype)) 
     
    17672036(defconstant $nhash.vector-overhead-delta 
    17682037  (- $new-nhash.vector-overhead $old-nhash.vector-overhead)) 
     2038 
     2039(defmethod %p-store-object (pheap (object hash-table) descend) 
     2040  (let* ((old-length (- (ccl::uvsize object) $nhash.vector-overhead-delta))) 
     2041    #-LispWorks (declare (fixnum length old-length)) 
     2042    (%p-store-as-uvector pheap object descend old-length $v_nhash))) 
    17692043 
    17702044(defun p-load-nhash (pheap disk-cache pointer depth subtype) 
     
    17792053                          (res (ccl::%cons-nhash-vector element-count)) 
    17802054                          (res-length (uvsize res))) 
    1781                      (declare (fixnum disk-length pairs element-count res-length)) 
     2055                     #-LispWorks (declare (fixnum disk-length pairs element-count res-length)) 
     2056                     #+LispWorks (assert (and (fixnump disk-length) 
     2057                                              (fixnump pairs) 
     2058                                              (fixnump element-count) 
     2059                                              (fixnump res-length))) 
    17822060                     (assert (eql (the fixnum (- length $old-nhash.vector-overhead)) 
    17832061                                  (the fixnum (- res-length $new-nhash.vector-overhead)))) 
     
    18032081    vector)) 
    18042082 
    1805 (defun p-store-nhash (pheap object descend) 
    1806   (let* ((length (uvsize object)) 
    1807          (old-length (- length $nhash.vector-overhead-delta))) 
    1808     (declare (fixnum length old-length)) 
    1809     (%p-store-object-body (pheap object descend disk-cache address) 
    1810       (dc-make-uvector disk-cache old-length $v_nhash) 
    1811       (progn 
    1812         (setf (dc-%svref disk-cache address $old-nhash.vector-header-size) $pheap-nil) 
    1813         (dotimes (i length) 
    1814           (declare (fixnum i)) 
    1815           (let ((j i)) 
    1816             (declare (fixnum j)) 
    1817             (unless (and (>= i $old-nhash.vector-header-size) 
    1818                          (progn (decf j $nhash.vector-overhead-delta) 
    1819                                 (< i $new-nhash.vector-overhead))) 
    1820               (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend) 
    1821                 (setf (dc-%svref disk-cache address j imm?) element))))))))) 
    1822  
     2083(defun p-store-nhash (pheap object descend disk-cache address old-length) 
     2084  (declare (ignore old-length)) 
     2085  (let ((length (ccl::uvsize object))) 
     2086    (setf (dc-%svref disk-cache address $old-nhash.vector-header-size) $pheap-nil) 
     2087    (dotimes (i length) 
     2088      (declare (fixnum i)) 
     2089      (let ((j i)) 
     2090        (declare (fixnum j)) 
     2091        (unless (and (>= i $old-nhash.vector-header-size) 
     2092                     (progn (decf j $nhash.vector-overhead-delta) 
     2093                       (< i $new-nhash.vector-overhead))) 
     2094          (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend) 
     2095            (setf (dc-%svref disk-cache address j imm?) element))))))) 
    18232096)  ; end of progn 
     2097 
     2098 
     2099#+LispWorks 
     2100(progn 
     2101 
     2102(def-indices 
     2103  $hash.test 
     2104  $hash.size 
     2105  $hash.rehash-size 
     2106  $hash.rehash-threshold 
     2107  $hash.hash-function 
     2108  $hash.weak-kind 
     2109  $hash.data) 
     2110 
     2111(defun hash-table-hash-function (hash) 
     2112  (cdr (system::hash-table-user-stuff hash))) 
     2113 
     2114(defun p-load-nhash (pheap disk-cache pointer depth subtype) 
     2115  (assert (eql subtype $v_nhash)) 
     2116  (flet ((load (index) 
     2117           (dc-%svref-value pheap disk-cache pointer index))) 
     2118    (declare (inline load)) 
     2119    (let* ((cached? t) 
     2120           (hash (maybe-cached-value pheap pointer 
     2121                   (setq cached? nil) 
     2122                   (let* ((test (load $hash.test)) 
     2123                          (size (load $hash.size)) 
     2124                          (rehash-size (load $hash.rehash-size)) 
     2125                          (rehash-threshold (load $hash.rehash-threshold)) 
     2126                          (hash-function (load $hash.hash-function)) 
     2127                          (weak-kind (load $hash.weak-kind))) 
     2128                     (make-hash-table :test test :size size 
     2129                                      :rehash-size rehash-size 
     2130                                      :rehash-threshold rehash-threshold 
     2131                                      :hash-function hash-function 
     2132                                      :weak-kind weak-kind))))) 
     2133      (when (or (not cached?) 
     2134                (and (eq depth t) 
     2135                     (let ((p-load-hash (p-load-hash pheap))) 
     2136                       (unless (gethash hash p-load-hash) 
     2137                         (setf (gethash hash p-load-hash) hash))))) 
     2138        (when cached? 
     2139          (unless (and (equal (load $hash.test) (hash-table-test hash)) 
     2140                       (equal (load $hash.rehash-size) (hash-table-rehash-size hash)) 
     2141                       (equal (load $hash.rehash-threshold) (hash-table-rehash-threshold hash)) 
     2142                       (equal (load $hash.hash-function) (hash-table-hash-function hash)) 
     2143                       (equal (load $hash.weak-kind) (system::hash-table-weak-kind hash))) 
     2144            (error "Incompatible parameters for ~s" hash)) 
     2145          (clrhash hash)) 
     2146        (loop for i from $hash.data below (dc-%simple-vector-length disk-cache pointer) by 2 
     2147              as key = (load i) 
     2148              as value = (load (1+ i)) 
     2149              do (setf (gethash key hash) value)) 
     2150        hash)))) 
     2151 
     2152(defmethod %p-store-object (pheap (object hash-table) descend) 
     2153  (let ((length (+ $hash.data (* 2 (hash-table-count object))))) 
     2154    (%p-store-as-uvector pheap object descend length $v_nhash))) 
     2155 
     2156(defun p-store-nhash (pheap object descend disk-cache address length) 
     2157  (declare (ignore length)) 
     2158  (flet ((store (index value) 
     2159           (multiple-value-bind (element imm?) (%p-store pheap value descend) 
     2160             (setf (dc-%svref disk-cache address index imm?) element)))) 
     2161    (declare (inline store)) 
     2162    (store $hash.test (hash-table-test object)) 
     2163    (store $hash.size (hash-table-size object)) 
     2164    (store $hash.rehash-size (hash-table-rehash-size object)) 
     2165    (store $hash.rehash-threshold (hash-table-rehash-threshold object)) 
     2166    (store $hash.hash-function (hash-table-hash-function object)) 
     2167    (store $hash.weak-kind (system::hash-table-weak-kind object)) 
     2168    (loop for i from $hash.data by 2 
     2169          for key being the hash-key of object using (hash-value value) 
     2170          do (store i key) 
     2171          do (store (1+ i) value)))) 
     2172 
     2173) ;#+LispWorks 
     2174 
     2175 
     2176 
    18242177 
    18252178;;;;;;;;;;;;;;;;;;;;;;;;;; 
     
    18842237    `(progn 
    18852238       (defun ,p-name (,p ,@args) 
    1886          ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?)))) 
     2239         ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?))) #+LispWorks `((declare (ignore ignore)))) 
    18872240         (p-dispatch (,p ,@args-sans-keywords) 
    18882241                     ,dc-name ,lisp-accessor t ,rest-arg?)) 
    1889        (defun ,dc-name (,disk-cache ,pointer ,@args) 
     2242       ;; Workaround for stupid LispWorks compiler fascism:  when compiling (setf (foo ...) value), 
     2243       ;; it requires that ... must match FOO's arglist.  Since our (setf dc-xxx) method take an extra 
     2244       ;; imm? arg, put in a fake extra arg into the non-setf form as well. 
     2245       (defun ,dc-name (,disk-cache ,pointer ,@args #+LispWorks ,@(unless rest-arg? '(&optional ignore))) 
     2246         #+lispWorks ,@(unless rest-arg? `((declare (ignore ignore)))) 
    18902247         ,@body)))) 
    18912248 
     
    19352292  (pointer-tagp pointer $t_symbol)) 
    19362293 
     2294(defun-inline %array-subtype-p (subtype) 
     2295  (declare (fixnum subtype)) 
     2296  (or (and (<= $v_min_arr subtype) (<= subtype $v_arrayh)) 
     2297      #+LispWorks (eql subtype $v_garrayh) 
     2298      #+LispWorks (eql subtype $v_iarrayh))) 
     2299 
     2300(defun-inline %arrayh-subtype-p (subtype) 
     2301  (declare (fixnum subtype)) 
     2302  (or (eql $v_arrayh subtype) 
     2303      #+LispWorks (eql $v_garrayh subtype) 
     2304      #+LispWorks (eql $v_iarrayh subtype))) 
     2305   
     2306 
    19372307(def-predicate arrayp (p disk-cache pointer) 
    19382308  (and (pointer-tagp pointer $t_vector) 
    1939        (let ((subtype (dc-%vector-subtype disk-cache pointer))) 
    1940          (declare (fixnum subtype)) 
    1941          (and (<= $v_min_arr subtype) (<= subtype $v_arrayh))))) 
     2309       (%array-subtype-p (dc-%vector-subtype disk-cache pointer)))) 
     2310 
     2311(defun dc-array-header-p (disk-cache pointer) 
     2312  (and (pointer-tagp pointer $t_vector) 
     2313       (%arrayh-subtype-p (dc-%vector-subtype disk-cache pointer)))) 
    19422314 
    19432315(defun dc-array-subtype-satisfies-p (disk-cache array predicate) 
    19442316  (and (pointer-tagp array $t_vector) 
    19452317       (let ((subtype (dc-%vector-subtype disk-cache array))) 
    1946          (if (eql $v_arrayh subtype) 
     2318         (if (%arrayh-subtype-p subtype) 
    19472319           (values 
    19482320            (funcall predicate 
     
    19512323           (funcall predicate subtype))))) 
    19522324 
     2325;; TODO: this isn't enough for LispWorks, lispworks sys:augmented-string is 
     2326;; a $v_garrayh array with element-type = 'character. 
    19532327(def-predicate stringp (p disk-cache pointer) 
    19542328  (multiple-value-bind (stringp arrayhp) 
    19552329                       (dc-array-subtype-satisfies-p 
    19562330                        disk-cache pointer 
    1957                         #'(lambda (x) (eql x $v_sstr))) 
     2331                        #'(lambda (x) (or (eql x $v_sstr) (eql x $v_xstr)))) 
    19582332    (and stringp 
    19592333         (or (not arrayhp) 
     
    19642338                       (dc-array-subtype-satisfies-p 
    19652339                        disk-cache pointer 
    1966                         #'(lambda (x)  
    1967                             (declare (fixnum x)) 
    1968                             (and (<= $v_min_arr x) (< x $v_arrayh)))) 
     2340                        #'%array-subtype-p) 
    19692341    (and arrayp 
    19702342         (or (not arrayhp) 
     
    20162388         (page-offset 0) 
    20172389         (offset (require-type offset 'fixnum))) 
    2018     (declare (fixnum page-size mask page-offset blocks-crossed offset)) 
     2390    (declare (fixnum page-size mask page-offset offset)) 
    20192391    (macrolet ((doit () 
    20202392                 `(progn 
     
    20342406        (doit))))) 
    20352407 
    2036 (def-accessor ccl::%svref (v index) (disk-cache v-pointer) 
     2408(def-accessor %svref (v index) (disk-cache v-pointer) 
    20372409  (read-pointer 
    20382410   disk-cache 
     
    20512423 
    20522424(defun dc-%simple-vector-length (disk-cache pointer) 
    2053   (the fixnum (ash (the fixnum (read-low-24-bits 
    2054                                 disk-cache (+ pointer $v_log))) 
     2425  (the fixnum (ash (the #+ccl fixnum #+LispWorks integer 
     2426                        (read-low-24-bits 
     2427                         disk-cache (+ pointer $v_log))) 
    20552428                   -2))) 
    20562429 
     
    20582431  (read-8-bits disk-cache (+ pointer $v_subtype))) 
    20592432 
    2060 (def-accessor ccl::%vect-subtype (p) (disk-cache pointer) 
     2433 
     2434(def-accessor %vect-subtype (p) (disk-cache pointer) 
    20612435  (values (dc-%vector-subtype disk-cache pointer) t)) 
    20622436 
     
    20782452      (error "Inconsistency: pointer at ~s was not a fixnum." address-name)) 
    20792453    value)) 
     2454 
     2455(defun dc-%svref-value (pheap disk-cache pointer index) 
     2456  (multiple-value-bind (value imm?) (dc-%svref disk-cache pointer index) 
     2457    (if imm? 
     2458      value 
     2459      (pointer-load pheap value :default disk-cache)))) 
     2460 
    20802461 
    20812462(def-accessor car (p) (disk-cache pointer) 
     
    22032584    (nth n list))) 
    22042585 
    2205 (defun dc-nth (disk-cache n list) 
     2586(defun dc-nth (disk-cache n list #+LispWorks &optional #+LispWorks ignore) 
     2587  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
    22062588  (dc-car disk-cache (dc-nthcdr disk-cache n list))) 
    22072589 
     
    22262608    (nthcdr n list))) 
    22272609 
    2228 (defun dc-nthcdr (disk-cache n list) 
     2610(defun dc-nthcdr (disk-cache n list #+LispWorks &optional #+LispWorks ignore) 
     2611  #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation. 
    22292612  (setq n (require-type n 'unsigned-byte)) 
    22302613  (loop 
     
    22402623        (setf (dc-nthcdr (pheap-disk-cache pheap) n (pptr-pointer list) imm?) pointer) 
    22412624        (if imm? pointer (pptr pheap pointer)))) 
    2242     (setf (nthcdr n list) value))) 
     2625    #+ccl(setf (nthcdr n list) value) 
     2626    #-ccl (if (eql n 0) value (setf (cdr (nthcdr (1- n) value)) value)))) 
    22432627 
    22442628(defun (setf dc-nthcdr) (value disk-cache n list &optional imm?) 
     
    23552739    (unless (< -1 index size) 
    23562740      (error "Index ~s out of range for ~s" index (dc-pointer-pptr disk-cache pointer))) 
     2741    ;; #+LispWorks *** TODO: Check endianness 
    23572742    (values (addr+ disk-cache pointer (+ $v_data 1 (ash index -3))) 
    23582743            (- 7 (logand index 7))))) 
     
    23662751       0) 
    23672752     t))) 
    2368               
     2753 
    23692754 
    23702755(defun (setf p-uvref) (value pptr index) 
     
    24432828      (setf (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset))) 
    24442829            (require-type value 'double-float)) 
     2830      ;; TODO: LispWorks doesn't actually stack-cons immediate arrays.  Should just 
     2831      ;; copy directly 
    24452832      (let ((buf (make-string 8 :element-type 'base-character))) 
    24462833        (declare (dynamic-extent buf)) 
    24472834        (require-satisfies pointer-tagp value $t_dfloat) 
    2448         (load-byte-array disk-cache (- value $t_dfloat) 8 buf) 
    2449         (store-byte-array buf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8) 
    2450         value))))         
     2835        (load-bytes-to-string disk-cache (- value $t_dfloat) 8 buf) 
     2836        (store-bytes-from-string buf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8) 
     2837        value)))) 
    24512838 
    24522839(defun uvset-bit-vector (value disk-cache pointer index immediate?) 
     
    24732860                                                     (pptr-pointer p)) 
    24742861        (values (pptr pheap address) offset))) 
    2475     (ccl::array-data-and-offset p))) 
     2862    (array-data-and-offset p))) 
    24762863 
    24772864(defun dc-array-data-and-offset (disk-cache pointer) 
    24782865  (require-satisfies dc-arrayp disk-cache pointer) 
    2479   (if (not (dc-vector-subtype-p disk-cache pointer $v_arrayh)) 
     2866  (if (not (dc-array-header-p disk-cache pointer)) 
    24802867    (values pointer 0) 
    24812868    (let* ((p pointer) 
     
    24992886 
    25002887(defun dc-%vector-length (disk-cache pointer) 
    2501   (if (eql $v_arrayh (dc-%vector-subtype disk-cache pointer)) 
     2888  (if (%arrayh-subtype-p (dc-%vector-subtype disk-cache pointer)) 
    25022889    (if (logbitp $arh_fill_bit (dc-%arrayh-bits disk-cache pointer)) 
    25032890      (dc-%svref disk-cache pointer $arh.fill) 
     
    25272914(def-accessor symbol-value (p) (disk-cache pointer) 
    25282915  (let ((values (dc-symbol-values-list disk-cache pointer))) 
    2529     (let ((value (ccl::%unbound-marker-8)) 
     2916    (let ((value (%unbound-marker)) 
    25302917          (value-imm? t)) 
    25312918      (when values 
    25322919        (multiple-value-setq (value value-imm?) (dc-car disk-cache values))) 
    2533       (when (and value-imm? (eq value (ccl::%unbound-marker-8))) 
     2920      (when (and value-imm? (eq value (%unbound-marker))) 
    25342921        (dc-error "Unbound variable: ~s = ~s" disk-cache pointer)) 
    25352922      (values value value-imm?)))) 
     
    29563343      res))) 
    29573344 
     3345#-LispWorks 
    29583346(eval-when (:compile-toplevel :execute) 
    29593347  (assert (< (expt 2 24) most-positive-fixnum))) 
    29603348 
     3349#-LispWorks 
    29613350(assert (fixnump (1- (expt 2 24)))) 
    29623351 
     
    29683357  (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)) 
    29693358         (size (* length bytes-per-element))) 
    2970     (unless (< size (expt 2 24)) 
     3359    (unless (<= size (- (min #.(1- (expt 2 24)) most-positive-fixnum) $vector-header-size)) 
    29713360      (error "Attempt to allocate a vector larger than ~s bytes long" 
    2972              (1- (expt 2 24)))) 
     3361             (- (min #.(1- (expt 2 24)) most-positive-fixnum) $vector-header-size))) 
    29733362    (locally (declare (fixnum size)) 
    29743363      (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size size)))) 
     
    30183407           ; Try the next segment in the free list 
    30193408           (%allocate-storage-internal 
    3020             disk-cache area free-link size segment initial-segment) 
     3409            disk-cache area #+remove free-link size segment initial-segment) 
    30213410           ; Does not fit in any of the existing segments. Make a new one. 
    30223411           (let ((new-segment (dc-cons-segment 
     
    31513540        (0) 
    31523541        (1 (setq initial-element #xff)))) 
    3153     (locally (declare (fixnum bytes)) 
     3542    (locally #-LispWorks(declare (fixnum bytes)) 
    31543543      (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size bytes))) 
    31553544             (res (initialize-vector-storage 
     
    32783667  (p-uvector pheap $v_weakh nil type data)) 
    32793668 
     3669#+CCL 
    32803670(def-accessor ccl::population-data (p) (disk-cache pointer) 
    32813671  (require-satisfies dc-vector-subtype-p disk-cache pointer $v_weakh) 
     
    35553945                  (return-from %p-store-hash-key nil)))))))) 
    35563946 
     3947(defconstant $null-char (code-char 0)) 
     3948 
    35573949(defmacro with-dc-hash-key ((key-var key key-imm?) &body body) 
    35583950  (let ((s4 (gensym)) 
     
    35683960       (%store-pointer ,key ,s4 0 ,key-imm?) 
    35693961       (locally (declare (optimize (speed 3) (safety 0))) 
    3570          (if (eql #\000 (schar ,s4 0)) 
    3571            (if (eql #\000 (schar ,s4 1)) 
    3572              (if (eql #\000 (schar ,s4 2)) 
     3962         (if (eql $null-char (schar ,s4 0)) 
     3963           (if (eql $null-char (schar ,s4 1)) 
     3964             (if (eql $null-char (schar ,s4 2)) 
    35733965               (setf (schar ,s1 0) (schar ,s4 3) 
    35743966                     ,key-var ,s1) 
     
    35923984            (setf (schar s 1) 
    35933985                  (setf (schar s 2) 
    3594                         (setf (schar s 3) #\000))))) 
     3986                        (setf (schar s 3) $null-char))))) 
    35953987    (if (> len 4) (error "Bad hash-table key-string: ~s" key-string)) 
    35963988    (%copy-byte-array-portion key-string 0 len s (the fixnum (- 4 len))) 
     
    36914083  (if (pptr-p p) 
    36924084    (dc-vector-subtype-p (pptr-disk-cache p) (pptr-pointer p) subtype) 
    3693     (ccl::uvector-subtype-p p subtype))) 
     4085    (uvector-subtype-p p subtype))) 
    36944086 
    36954087(defun pload-barrier-p (object) 
     
    37024094;;; 
    37034095 
     4096 
    37044097(defparameter *p-load-subtype-functions* 
    3705   #(p-load-error                        ;($v_packed_sstr 0) 
    3706     p-load-bignum                       ;($v_bignum 1) 
    3707     p-load-error                        ;($v_macptr 2) - not supported 
    3708     p-load-ivector                      ;($v_badptr 3) 
    3709     p-load-lfun-vector                  ;($v_nlfunv 4) 
    3710     p-load-error                        ;subtype 5 unused 
    3711     p-load-ivector                      ;($v_xstr 6)      ;extended string 
    3712     p-load-ivector                      ;($v_ubytev 7)    ;unsigned byte vector 
    3713     p-load-ivector                      ;($v_uwordv 8)    ;unsigned word vector 
    3714     p-load-ivector                      ;($v_floatv 9)    ;float vector 
    3715     p-load-ivector                      ;($v_slongv 10)   ;Signed long vector 
    3716     p-load-ivector                      ;($v_ulongv 11)   ;Unsigned long vector 
    3717     #-ppc-target p-load-ivector         ;($v_bitv 12)     ;Bit vector 
    3718     #+ppc-target p-load-bit-vector 
    3719     p-load-ivector                      ;($v_sbytev 13)   ;Signed byte vector 
    3720     p-load-ivector                      ;($v_swordv 14)   ;Signed word vector 
    3721     p-load-ivector                      ;($v_sstr 15)     ;simple string 
    3722     p-load-gvector                      ;($v_genv 16)     ;simple general vector 
    3723     p-load-arrayh                       ;($v_arrayh 17)   ;complex array header 
    3724     p-load-struct                       ;($v_struct 18)   ;structure 
    3725     p-load-error                        ;($v_mark 19)     ;buffer mark 
    3726     p-load-pkg                          ;($v_pkg 20) 
    3727     p-load-error                        ;subtype 21 unused 
    3728     p-load-istruct                      ;($v_istruct 22) 
    3729     p-load-ivector                      ;($v_ratio 23) 
    3730     p-load-ivector                      ;($v_complex 24) 
    3731     p-load-instance                     ;($v_instance 25) ;clos instance 
    3732     p-load-error                        ;subtype 26 unused 
    3733     p-load-error                        ;subtype 27 unused 
    3734     p-load-error                        ;subtype 28 unused 
    3735     p-load-header                       ;($v_weakh 29) 
    3736     p-load-header                       ;($v_poolfreelist 30) 
    3737     p-load-nhash                        ;($v_nhash 31) 
    3738     ; internal subtypes 
    3739     p-load-nop                          ;($v_area 32) 
    3740     p-load-nop                          ;($v_segment 33) 
    3741     p-load-nop                          ;($v_random-bits 34) 
    3742     p-load-nop                          ;($v_dbheader 35) 
    3743     p-load-nop                          ;($v_segment-headers 36) 
    3744     p-load-nop                          ;($v_btree 37) 
    3745     p-load-nop                          ;($v_btree-node 38) 
    3746     p-load-class                        ;($v_class 39) 
    3747     p-load-load-function                ;($v_load-function 40) 
    3748     p-load-pload-barrier                ;($v_pload-barrier 41) 
    3749     )) 
     4098  (vtype-vector :unused p-load-error 
     4099                :bignum p-load-bignum 
     4100                #+ccl :badptr #+ccl p-load-ivector 
     4101                #+ccl :nlfunv #+ccl p-load-lfun-vector 
     4102                :xstr p-load-ivector 
     4103                :ubytev p-load-ivector 
     4104                :uwordv p-load-ivector 
     4105                :floatv p-load-ivector 
     4106                :slongv p-load-ivector 
     4107                :ulongv p-load-ivector 
     4108                :bitv #+ccl-68k-target p-load-ivector #-ccl-68k-target p-load-bit-vector 
     4109                :sbytev p-load-ivector 
     4110                :swordv p-load-ivector 
     4111                :sstr p-load-ivector 
     4112                :genv p-load-gvector 
     4113                :arrayh p-load-arrayh 
     4114                #+LispWorks :garrayh #+LispWorks p-load-arrayh 
     4115                #+LispWorks :iarrayh #+LispWorks p-load-arrayh 
     4116                :struct p-load-struct 
     4117                :pkg p-load-pkg 
     4118                #+ccl :istruct #+ccl p-load-istruct 
     4119                :ratio #+ccl p-load-ivector #-ccl p-load-ratio 
     4120                :complex #+ccl p-load-ivector #-ccl p-load-complex 
     4121                :instance p-load-instance 
     4122                #+ccl :weakh #+ccl p-load-header 
     4123                #+ccl :poolfreelist #+ccl p-load-header 
     4124                :nhash p-load-nhash 
     4125                :area p-load-nop 
     4126                :segment p-load-nop 
     4127                :random-bits p-load-nop 
     4128                :dbheader p-load-nop 
     4129                :segment-headers p-load-nop 
     4130                :btree p-load-nop 
     4131                :btree-node p-load-nop 
     4132                :class p-load-class 
     4133                :load-function p-load-load-function 
     4134                :pload-barrier p-load-pload-barrier)) 
    37504135 
    37514136(defparameter *subtype->bytes-per-element* 
    3752   #(nil                                 ; 0 - unused 
    3753     2                                   ; 1 - $v_bignum 
    3754     nil                                 ; 2 - $v_macptr - not supported 
    3755     4                                   ; 3 - $v_badptr 
    3756     2                                   ; 4 - $v_nlfunv 
    3757     nil                                 ; 5 - unused 
    3758     2                                   ; 6 - $v_xstr - extended string 
    3759     1                                   ; 7 - $v_ubytev - unsigned byte vector 
    3760     2                                   ; 8 - $v_uwordv - unsigned word vector 
    3761     8                                   ; 9 - $v_floatv - float vector 
    3762     4                                   ; 10 - $v_slongv - Signed long vector 
    3763     4                                   ; 11 - $v_ulongv - Unsigned long vector 
    3764     nil                                   ; 12 - $v_bitv - Bit vector (handled specially) 
    3765     1                                   ; 13 - $v_sbytev - Signed byte vector 
    3766     2                                   ; 14 - $v_swordv - Signed word vector 
    3767     1                                   ; 15 - $v_sstr - simple string 
    3768     4                                   ; 16 - $v_genv - simple general vector 
    3769     4                                   ; 17 - $v_arrayh - complex array header 
    3770     4                                   ; 18 - $v_struct - structure 
    3771     nil                                 ; 19 - $v_mark - buffer mark unimplemented 
    3772     4                                   ; 20 - $v_pkg 
    3773     nil                                 ; 21 - unused 
    3774     4                                   ; 22 - $v_istruct - type in first element 
    3775     4                                   ; 23 - $v_ratio 
    3776     4                                   ; 24 - $v_complex 
    3777     4                                   ; 25 - $v_instance - clos instance 
    3778     nil                                 ; 26 - unused 
    3779     nil                                 ; 27 - unused 
    3780     nil                                 ; 28 - unused 
    3781     4                                   ; 29 - $v_weakh - weak list header 
    3782     4                                   ; 30 - $v_poolfreelist - free pool header 
    3783     4                                   ; 31 - $v_nhash 
    3784     ; WOOD specific subtypes 
    3785     4                                   ; 32 - $v_area - area descriptor 
    3786     4                                   ; 33 - $v_segment - area segment 
    3787     1                                   ; 34 - $v_random-bits - vectors of random bits, e.g. resources 
    3788     4                                   ; 35 - $v_dbheader - database header 
    3789     nil                                 ; 36 - $v_segment-headers - specially allocated 
    3790     4                                   ; 37 - $v_btree 
    3791     nil                                 ; 38 - $v_btree-node - specially allocated 
    3792     4                                   ; 39 - $v_class 
    3793     4                                   ; 40 - $v_load-function 
    3794     4                                   ;($v_pload-barrier 41) 
    3795     )) 
     4137  (vtype-vector :bignum 2 
     4138                :badptr 4 
     4139                :nlfunv 2 
     4140                :xstr 2 
     4141                :ubytev 1 
     4142                :uwordv 2 
     4143                :floatv 8 
     4144                :slongv 4 
     4145                :ulongv 4 
     4146                :bitv 1/8 
     4147                :sbytev 1 
     4148                :swordv 2 
     4149                :sstr 1 
     4150                :genv 4 
     4151                :arrayh 4 
     4152                :garrayh 4 
     4153                :iarrayh 1 
     4154                :struct 4 
     4155                :pkg 4 
     4156                :istruct 4 
     4157                :ratio 4 
     4158                :complex 4 
     4159                :instance 4 
     4160                :weakh 4 
     4161                :poolfreelist 4 
     4162                :nhash 4 
     4163                :area 4 
     4164                :segment 4 
     4165                :random-bits 1 
     4166                :dbheader 4 
     4167                :btree 4 
     4168                :class 4 
     4169                :load-function 4 
     4170                :pload-barrier 4)) 
     4171 
     4172 
     4173#+LispWorks 
     4174(defparameter *subtype->array-byte-offset* 
     4175  (vtype-vector :unused 0 
     4176                :floatv #.$floatv-read-offset)) 
     4177 
     4178 
     4179#+LispWorks 
     4180(defparameter *subtype->array-element-type* 
     4181  (vtype-vector :xstr simple-character 
     4182                :ubytev (unsigned-byte 8) 
     4183                :uwordv (unsigned-byte 16) 
     4184                :floatv double-float 
     4185                :slongv (signed-byte 32) 
     4186                :ulongv (unsigned-byte 32) 
     4187                :bitv (unsigned-byte 1) 
     4188                :sbytev (signed-byte 8) 
     4189                :swordv (signed-byte 16) 
     4190                :sstr base-character 
     4191                :genv t)) 
     4192 
     4193 
    37964194 
    37974195(defparameter *p-store-subtype-functions* 
    3798   #(nil                                 ;($v_packed_sstr 0) 
    3799     p-store-ivector                     ;($v_bignum 1) 
    3800     nil                                 ;($v_macptr 2) - not supported 
    3801     p-store-ivector                     ;($v_badptr 3) 
    3802     nil                                 ;($v_nlfunv 4) 
    3803     nil                                 ;subtype 5 unused 
    3804     p-store-ivector                     ;($v_xstr 6)      ;16-bit string 
    3805     p-store-ivector                     ;($v_ubytev 7)    ;unsigned byte vector 
    3806     p-store-ivector                     ;($v_uwordv 8)    ;unsigned word vector 
    3807     p-store-ivector                     ;($v_floatv 9)    ;float vector 
    3808     p-store-ivector                     ;($v_slongv 10)   ;Signed long vector 
    3809     p-store-ivector                     ;($v_ulongv 11)   ;Unsigned long vector 
    3810     #-ppc-target p-store-ivector        ;($v_bitv 12)     ;Bit vector 
    3811     #+ppc-target p-store-bit-vector 
    3812     p-store-ivector                     ;($v_sbytev 13)   ;Signed byte vector 
    3813     p-store-ivector                     ;($v_swordv 14)   ;Signed word vector 
    3814     p-store-ivector                     ;($v_sstr 15)     ;simple string 
    3815     p-store-gvector                     ;($v_genv 16)     ;simple general vector 
    3816     p-store-gvector                     ;($v_arrayh 17)   ;complex array header 
    3817     p-store-gvector                     ;($v_struct 18)   ;structure 
    3818     nil                                 ;($v_mark 19)     ;buffer mark 
    3819     nil                                 ;($v_pkg 20) 
    3820     nil                                 ;subtype 21 unused 
    3821     p-store-gvector                     ;($v_istruct 22) 
    3822     p-store-ivector                     ;($v_ratio 23) 
    3823     p-store-ivector                     ;($v_complex 24) 
    3824     nil                                 ;($v_instance 25) ;clos instance 
    3825     nil                                 ;subtype 26 unused 
    3826     nil                                 ;subtype 27 unused 
    3827     nil                                 ;subtype 28 unused 
    3828     p-store-gvector                     ;($v_weakh 29) 
    3829     p-store-gvector                     ;($v_poolfreelist 30) 
    3830     p-store-gvector                     ;($v_nhash 31) 
    3831     )) 
     4196  (vtype-vector :bignum #-ccl-68k-target p-store-bignum 
     4197                        #+ccl-68k-target p-store-ivector 
     4198                #+ccl :badptr #+ccl p-store-ivector 
     4199                #+ccl :xstr #+ccl p-store-ivector 
     4200                :ubytev p-store-ivector                   ;unsigned byte vector 
     4201                :uwordv p-store-ivector                   ;unsigned word vector 
     4202                :floatv p-store-ivector                   ;float vector 
     4203                :slongv p-store-ivector                   ;Signed long vector 
     4204                :ulongv p-store-ivector                   ;Unsigned long vector 
     4205                :bitv #-ccl-68k-target p-store-bit-vector 
     4206                      #+ccl-68k-target p-store-ivector 
     4207                :sbytev p-store-ivector                   ;Signed byte vector 
     4208                :swordv p-store-ivector                   ;Signed word vector 
     4209                :sstr p-store-ivector                     ;simple string 
     4210                :genv p-store-gvector                     ;simple general vector 
     4211                :arrayh #-ccl-68k-target p-store-arrayh   ;complex array header 
     4212                        #+ccl-68k-target p-store-gvector 
     4213                :garrayh p-store-garrayh 
     4214                :iarrayh p-store-iarrayh 
     4215                :struct #+ccl p-store-gvector #-ccl p-store-struct    ;structure 
     4216                :istruct p-store-gvector 
     4217                :ratio #+ccl p-store-ivector ;; ???? 
     4218                       #-ccl p-store-ratio 
     4219                :complex #+ccl p-store-ivector ;; ???? 
     4220                         #-ccl p-store-gvector 
     4221                :weakh p-store-gvector 
     4222                :poolfreelist p-store-g-vector 
     4223                :nhash #+(or (not ccl) ccl-3) p-store-nhash 
     4224                       #-(or (not ccl) ccl-3) p-store-gvector)) 
    38324225 
    38334226(defparameter *subtype->uvreffer* 
    3834   #(nil                                 ; 0 - unused 
    3835     uvref-unsigned-word                 ; 1 - $v_bignum 
    3836     nil                                 ; 2 - $v_macptr - not supported 
    3837     uvref-unsigned-long                 ; 3 - $v_badptr 
    3838     uvref-unsigned-word                 ; 4 - $v_nlfunv 
    3839     nil                                 ; 5 - unused 
    3840     uvref-extended-string               ; 6 - $v_xstr - extended string 
    3841     uvref-unsigned-byte                 ; 7 - $v_ubytev - unsigned byte vector 
    3842     uvref-unsigned-word                 ; 8 - $v_uwordv - unsigned word vector 
    3843     uvref-dfloat                        ; 9 - $v_floatv - float vector 
    3844     uvref-signed-long                   ; 10 - $v_slongv - Signed long vector 
    3845     uvref-unsigned-long                 ; 11 - $v_ulongv - Unsigned long vector 
    3846     uvref-bit-vector                    ; 12 - $v_bitv - Bit vector 
    3847     uvref-signed-byte                   ; 13 - $v_sbytev - Signed byte vector 
    3848     uvref-signed-word                   ; 14 - $v_swordv - Signed word vector 
    3849     uvref-string                        ; 15 - $v_sstr - simple string 
    3850     uvref-genv                          ; 16 - $v_genv - simple general vector 
    3851     uvref-genv                          ; 17 - $v_arrayh - complex array header 
    3852     uvref-genv                          ; 18 - $v_struct - structure 
    3853     nil                                 ; 19 - $v_mark - buffer mark unimplemented 
    3854     uvref-genv                          ; 20 - $v_pkg 
    3855     nil                                 ; 21 - unused 
    3856     uvref-genv                          ; 22 - $v_istruct - type in first element 
    3857     uvref-genv                          ; 23 - $v_ratio 
    3858     uvref-genv                          ; 24 - $v_complex 
    3859     uvref-genv                          ; 25 - $v_instance - clos instance 
    3860     nil                                 ; 26 - unused 
    3861     nil                                 ; 27 - unused 
    3862     nil                                 ; 28 - unused 
    3863     uvref-genv                          ; 29 - $v_weakh - weak list header 
    3864     uvref-genv                          ; 30 - $v_poolfreelist - free pool header 
    3865     uvref-genv                          ; 31 - $v_nhash 
    3866     ; WOOD specific subtypes 
    3867     uvref-genv                          ; 32 - $v_area - area descriptor 
    3868     uvref-genv                          ; 33 - $v_segment - area segment 
    3869     uvref-unsigned-byte                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources 
    3870     uvref-genv                          ; 35 - $v_dbheader - database header 
    3871     nil                                 ; 36 - $v_segment-headers - specially allocated 
    3872     uvref-genv                          ; 37 - $v_btree 
    3873     nil                                 ; 38 - $v_btree-node - specially allocated 
    3874     uvref-genv                          ; 39 - $v_class 
    3875     uvref-genv                          ; 40 - $v_load-function 
    3876     uvref-genv                          ; 41 - $v_pload-barrier 
    3877     )) 
     4227  (vtype-vector :bignum uvref-unsigned-word 
     4228                :badptr uvref-unsigned-long 
     4229                :nlfunv uvref-unsigned-word 
     4230                :xstr uvref-extended-string 
     4231                :ubytev uvref-unsigned-byte 
     4232                :uwordv uvref-unsigned-word 
     4233                :floatv uvref-dfloat 
     4234                :slongv uvref-signed-long 
     4235                :ulongv uvref-unsigned-long 
     4236                :bitv uvref-bit-vector 
     4237                :sbytev uvref-signed-byte 
     4238                :swordv uvref-signed-word 
     4239                :sstr uvref-string 
     4240                :genv uvref-genv 
     4241                :arrayh uvref-genv 
     4242                :garrayh uvref-genv 
     4243                :iarrayh uvref-unsigned-byte 
     4244                :struct uvref-genv 
     4245                :pkg uvref-genv 
     4246                :istruct uvref-genv 
     4247                :ratio uvref-genv 
     4248                :complex uvref-genv 
     4249                :instance uvref-genv 
     4250                :weakh uvref-genv 
     4251                :poolfreelist uvref-genv 
     4252                :nhash uvref-genv 
     4253                ; WOOD specific subtypes 
     4254                :area uvref-genv 
     4255                :segment uvref-genv 
     4256                :random-bits uvref-unsigned-byte 
     4257                :dbheader uvref-genv 
     4258                :btree uvref-genv 
     4259                :class uvref-genv 
     4260                :load-function uvref-genv 
     4261                :pload-barrier uvref-genv)) 
    38784262 
    38794263(defparameter *subtype->uvsetter* 
    3880   #(nil                                 ; 0 - unused 
    3881     uvset-word                          ; 1 - $v_bignum 
    3882     nil                                 ; 2 - $v_macptr - not supported 
    3883     uvset-long                          ; 3 - $v_badptr 
    3884     uvset-word                          ; 4 - $v_nlfunv 
    3885     nil                                 ; 5 - unused 
    3886     uvset-extended-string               ; 6 - $v_xstr - extended string 
    3887     uvset-byte                          ; 7 - $v_ubytev - unsigned byte vector 
    3888     uvset-word                          ; 8 - $v_uwordv - unsigned word vector 
    3889     uvset-dfloat                        ; 9 - $v_floatv - float vector 
    3890     uvset-long                          ; 10 - $v_slongv - Signed long vector 
    3891     uvset-long                          ; 11 - $v_ulongv - Unsigned long vector 
    3892     uvset-bit-vector                    ; 12 - $v_bitv - Bit vector 
    3893     uvset-byte                          ; 13 - $v_sbytev - Signed byte vector 
    3894     uvset-word                          ; 14 - $v_swordv - Signed word vector 
    3895     uvset-string                        ; 15 - $v_sstr - simple string 
    3896     uvset-genv                          ; 16 - $v_genv - simple general vector 
    3897     uvset-genv                          ; 17 - $v_arrayh - complex array header 
    3898     uvset-genv                          ; 18 - $v_struct - structure 
    3899     nil                                 ; 19 - $v_mark - buffer mark unimplemented 
    3900     uvset-genv                          ; 20 - $v_pkg 
    3901     nil                                 ; 21 - unused 
    3902     uvset-genv                          ; 22 - $v_istruct - type in first element 
    3903     uvset-genv                          ; 23 - $v_ratio 
    3904     uvset-genv                          ; 24 - $v_complex 
    3905     uvset-genv                          ; 25 - $v_instance - clos instance 
    3906     nil                                 ; 26 - unused 
    3907     nil                                 ; 27 - unused 
    3908     nil                                 ; 28 - unused 
    3909     uvset-genv                          ; 29 - $v_weakh - weak list header 
    3910     uvset-genv                          ; 30 - $v_poolfreelist - free pool header 
    3911     uvset-genv                          ; 31 - $v_nhash 
    3912     ; WOOD specific subtypes 
    3913     uvset-genv                          ; 32 - $v_area - area descriptor 
    3914     uvset-genv                          ; 33 - $v_segment - area segment 
    3915     uvset-byte                          ; 34 - $v_random-bits - vectors of random bits, e.g. resources 
    3916     uvset-genv                          ; 35 - $v_dbheader - database header 
    3917     nil                                 ; 36 - $v_segment-headers - specially allocated 
    3918     uvset-genv                          ; 37 - $v_btree 
    3919     nil                                 ; 38 - $v_btree-node - specially allocated 
    3920     uvset-genv                          ; 39 - $v_class 
    3921     uvset-genv                          ; 40 - $v_load-function 
    3922     uvset-genv                          ; 41 - $v_pload-barrier 
    3923     )) 
     4264  (vtype-vector :bignum uvset-word 
     4265                :badptr uvset-long 
     4266                :nlfunv uvset-word 
     4267                :xstr uvset-extended-string 
     4268                :ubytev uvset-byte 
     4269                :uwordv uvset-word 
     4270                :floatv uvset-dfloat 
     4271                :slongv uvset-long 
     4272                :ulongv uvset-long 
     4273                :bitv uvset-bit-vector 
     4274                :sbytev uvset-byte 
     4275                :swordv uvset-word 
     4276                :sstr uvset-string 
     4277                :genv uvset-genv 
     4278                :arrayh uvset-genv 
     4279                :garrayh uvset-genv 
     4280                :iarrayh uvset-byte 
     4281                :struct uvset-genv 
     4282                :pkg uvset-genv 
     4283                :istruct uvset-genv 
     4284                :ratio uvset-genv 
     4285                :complex uvset-genv 
     4286                :instance uvset-genv 
     4287                :weakh uvset-genv 
     4288                :poolfreelist uvset-genv 
     4289                :nhash uvset-genv 
     4290                ; WOOD specific subtypes 
     4291                :area uvset-genv 
     4292                :segment uvset-genv 
     4293                :random-bits uvset-byte 
     4294                :dbheader uvset-genv 
     4295                :btree uvset-genv 
     4296                :class uvset-genv 
     4297                :load-function uvset-genv 
     4298                :pload-barrier uvset-genv)) 
    39244299 
    39254300(defparameter *subtype-initial-element* 
    3926   #(nil                                 ; 0 - unused 
    3927     nil                                 ; 1 - $v_bignum 
    3928     nil                                 ; 2 - $v_macptr not implemented 
    3929     nil                                 ; 3 - $v_badptr not implemented 
    3930     nil                                 ; 4 - $v_nlfunv 
    3931     nil                                 ; 5 - unused 
    3932     nil                                 ; 6 - $v_xstr - extended string 
    3933     nil                                 ; 7 - $v_ubytev - unsigned byte vector 
    3934     nil                                 ; 8 - $v_uwordv - unsigned word vector 
    3935     0                                   ; 9 - $v_floatv - float vector 
    3936     nil                                 ; 10 - $v_slongv - Signed long vector 
    3937     nil                                 ; 11 - $v_ulongv - Unsigned long vector 
    3938     nil                                 ; 12 - $v_bitv - Bit vector 
    3939     nil                                 ; 13 - $v_sbytev - Signed byte vector 
    3940     nil                                 ; 14 - $v_swordv - Signed word vector 
    3941     nil                                 ; 15 - $v_sstr - simple string 
    3942     #.$pheap-nil                        ; 16 - $v_genv - simple general vector 
    3943     #.$pheap-nil                        ; 17 - $v_arrayh - complex array header 
    3944     #.$pheap-nil                        ; 18 - $v_struct - structure 
    3945     nil                                 ; 19 - $v_mark - buffer mark unimplemented 
    3946     #.$pheap-nil                        ; 20 - $v_pkg 
    3947     nil                                 ; 21 - unused 
    3948     #.$pheap-nil                        ; 22 - $v_istruct - type in first element 
    3949     0                                   ; 23 - $v_ratio 
    3950     0                                   ; 24 - $v_complex 
    3951     #.$pheap-nil                        ; 25 - $v_instance - clos instance 
    3952     nil                                 ; 26 - unused 
    3953     nil                                 ; 27 - unused 
    3954     nil                                 ; 28 - unused 
    3955     #.$pheap-nil                        ; 29 - $v_weakh - weak list header 
    3956     #.$pheap-nil                        ; 30 - $v_poolfreelist - free pool header 
    3957     nil                                 ; 31 - $v_nhash unused 
    3958     #.$pheap-nil                        ; 32 - $v_area - area descriptor 
    3959     #.$pheap-nil                        ; 33 - $v_segment - area segment 
    3960     nil                                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources 
    3961     #.$pheap-nil                        ; 35 - $v_dbheader - database header 
    3962     nil                                 ; 36 - $v_segment-headers - specially allocated 
    3963     #.$pheap-nil                        ; 37 - $v_btree 
    3964     nil                                 ; 38 - $v_btree-node - specially allocated 
    3965     #.$pheap-nil                        ; 39 - $v_class 
    3966     #.$pheap-nil                        ; 40 - $v_load-function 
    3967     #.$pheap-nil                        ; 41 - $v_pload-barrier 
    3968     )) 
     4301  (vtype-vector :floatv 0 
     4302                :genv #.$pheap-nil 
     4303                :arrayh #.$pheap-nil 
     4304                :garrayh #.$pheap-nil 
     4305                :struct #.$pheap-nil 
     4306                :pkg #.$pheap-nil 
     4307                :istruct #.$pheap-nil 
     4308                :ratio 0 
     4309                :complex 0 
     4310                :instance #.$pheap-nil 
     4311                :weakh #.$pheap-nil 
     4312                :poolfreelist #.$pheap-nil 
     4313                :area #.$pheap-nil 
     4314                :segment #.$pheap-nil 
     4315                :dbheader #.$pheap-nil 
     4316                :btree #.$pheap-nil 
     4317                :class #.$pheap-nil 
     4318                :load-function #.$pheap-nil 
     4319                :pload-barrier #.$pheap-nil)) 
    39694320 
    39704321#+ppc-target 
     
    40364387     
    40374388 
    4038 (defun init-temp-pheap () 
     4389(defun init-temp-pheap (&optional inspect?) 
    40394390  (declare (special pheap dc)) 
    40404391  (when (boundp 'pheap) 
     
    40444395  (setq pheap (open-pheap "temp.pheap") 
    40454396        dc (pheap-disk-cache pheap)) 
    4046   (dolist (w (windows :class 'inspector::inspector-window)) 
    4047     (window-close w)) 
    4048   (inspect dc)) 
    4049  
     4397  #+ccl (dolist (w (windows :class 'inspector::inspector-window)) 
     4398          (window-close w)) 
     4399  (when inspect? (inspect dc))) 
     4400 
     4401 
     4402(init-temp-pheap) 
    40504403(setq p $pheap-nil) 
    40514404 
    4052 (time 
    4053  (dotimes (i 200) 
    4054    (setq p (dc-cons dc i p t nil)))) 
     4405(defun test-cons (count &optional (p $pheap-nil)) 
     4406  (declare (special dc)) 
     4407  (dotimes (i count) 
     4408    (setq p (dc-cons dc i p t nil)))) 
     4409 
     4410(time (test-cons 20000)) 
    40554411 
    40564412(time 
  • lw-branch/q.lisp

    r3 r6  
    1 ;;;-*- Mode: Lisp; Package: CCL -*- 
     1;;;-*- Mode: Lisp; Package: Wood -*- 
    22 
    33;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
     
    66;; A simple fifo queue. Why isn't this part of Common Lisp 
    77;; 
     8;; Portions Copyright © 2006 Clozure Associates 
    89;; Copyright © 1996 Digitool, Inc. 
    910;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2021;; Modification History 
    2122;; 
     23;; 02/01/06 gz   LispWorks port 
    2224;; -------------  0.96 
    2325;; 08/27/96 bill  Added copyright and mod history comments 
    2426;; 
    2527 
    26 (in-package :ccl) 
     28(in-package #+ccl :ccl #-ccl :wood) 
    2729 
    2830(export '(make-q enq deq q-empty-p)) 
    2931 
    30 (require "LISPEQU")                     ; %cons-pool, pool.data 
     32#+ccl (require "LISPEQU")                     ; %cons-pool, pool.data 
    3133 
    3234(defstruct q 
     
    4143 
    4244(defconstant $q-buf-size 512) 
     45#+Lispworks (defconstant $max-num-q-bufs 20) 
    4346 
    44 (defvar *q-bufs* (%cons-pool)) 
     47(defvar *q-bufs*  
     48  #+ccl (%cons-pool) 
     49  #+LispWorks (let ((arr (make-array $max-num-q-bufs))) 
     50                (hcl:set-array-weak arr t) 
     51                arr)) 
    4552 
    4653(defun make-q-buf () 
    4754  (without-interrupts 
    48    (let ((buf (pool.data *q-bufs*))) 
    49      (if buf 
    50        (progn 
    51          (setf (pool.data *q-bufs*) (svref buf 0)) 
    52          (dotimes (i $q-buf-size) 
    53            (setf (svref buf i) nil)) 
    54          buf) 
    55        (make-array $q-buf-size))))) 
     55    #+ccl 
     56    (let ((buf (pool.data *q-bufs*))) 
     57      (if buf 
     58        (progn 
     59          (setf (pool.data *q-bufs*) (svref buf 0)) 
     60          (dotimes (i $q-buf-size) 
     61            (setf (svref buf i) nil)) 
     62          buf) 
     63        (make-array $q-buf-size))) 
     64    #+LispWorks 
     65    (let ((pos (position-if-not #'null *q-bufs*))) 
     66      (if pos 
     67        (let ((buf (aref *q-bufs* pos))) 
     68          (setf (aref *q-bufs* pos) nil) 
     69          (fill buf nil) 
     70          buf) 
     71        (make-array $q-buf-size))))) 
    5672 
    5773(defun free-q-buf (buf) 
    5874  (without-interrupts 
    59    (setf (svref buf 0) (pool.data *q-bufs*) 
    60          (pool.data *q-bufs*) buf) 
    61    nil)) 
     75    #+ccl 
     76    (setf (svref buf 0) (pool.data *q-bufs*) 
     77          (pool.data *q-bufs*) buf) 
     78    #+LispWorks 
     79    (let ((pos (position-if #'null *q-bufs*))) 
     80      (when pos 
     81        (setf (aref *q-bufs* pos) buf))) 
     82    nil)) 
    6283 
    6384(defun enq (q elt) 
  • lw-branch/wood-gc.lisp

    r3 r6  
    443443    (loop 
    444444      (when (< bytes-to-go 512) 
    445         (load-byte-array input-dc from bytes-to-go string 0 t) 
    446         (store-byte-array string output-dc to bytes-to-go 0 t) 
     445        (load-bytes-to-string input-dc from bytes-to-go string) 
     446        (store-bytes-from-string string output-dc to bytes-to-go) 
    447447        (return)) 
    448       (load-byte-array input-dc from 512 string 0 t) 
    449       (store-byte-array string output-dc to 512 0 t) 
     448      (load-bytes-to-string input-dc from 512 string) 
     449      (store-bytes-from-string string output-dc to 512) 
    450450      (setq from (addr+ input-dc from 512)) 
    451451      (setq to (addr+ output-dc to 512)) 
     
    459459 
    460460(defparameter *subtype-node-p* 
    461   #(nil                                 ; 0 - unused 
    462     nil                                 ; 1 - $v_bignum 
    463     nil                                 ; 2 - $v_macptr not implemented 
    464     nil                                 ; 3 - $v_badptr not implemented 
    465     t                                   ; 4 - $v_nlfunv 
    466     nil                                 ; 5 - unused 
    467     nil                                 ; 6 - unused 
    468     nil                                 ; 7 - $v_ubytev - unsigned byte vector 
    469     nil                                 ; 8 - $v_uwordv - unsigned word vector 
    470     nil                                 ; 9 - $v_floatv - float vector 
    471     nil                                 ; 10 - $v_slongv - Signed long vector 
    472     nil                                 ; 11 - $v_ulongv - Unsigned long vector 
    473     nil                                 ; 12 - $v_bitv - Bit vector 
    474     nil                                 ; 13 - $v_sbytev - Signed byte vector 
    475     nil                                 ; 14 - $v_swordv - Signed word vector 
    476     nil                                 ; 15 - $v_sstr - simple string 
    477     t                                   ; 16 - $v_genv - simple general vector 
    478     t                                   ; 17 - $v_arrayh - complex array header 
    479     t                                   ; 18 - $v_struct - structure 
    480     t                                   ; 19 - $v_mark - buffer mark unimplemented 
    481     t                                   ; 20 - $v_pkg 
    482     nil                                 ; 21 - unused 
    483     t                                   ; 22 - $v_istruct - type in first element 
    484     t                                   ; 23 - $v_ratio 
    485     t                                   ; 24 - $v_complex 
    486     t                                   ; 25 - $v_instance - clos instance 
    487     nil                                 ; 26 - unused 
    488     nil                                 ; 27 - unused 
    489     nil                                 ; 28 - unused 
    490     t                                   ; 29 - $v_weakh - weak list header 
    491     t                                   ; 30 - $v_poolfreelist - free pool header 
    492     t                                   ; 31 - $v_nhash unused 
    493     t                                   ; 32 - $v_area - area descriptor 
    494     t                                   ; 33 - $v_segment - area segment 
    495     nil                                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources 
    496     t                                   ; 35 - $v_dbheader - database header 
    497     nil                                 ; 36 - $v_segment-headers - specially allocated 
    498     t                                   ; 37 - $v_btree 
    499     nil                                 ; 38 - $v_btree-node - specially allocated 
    500     t                                   ; 39 - $v_class 
    501     t                                   ; 40 - $v_load-function 
    502     )) 
     461  (vtype-vector :nlfunv t 
     462                :genv t 
     463                :arrayh t 
     464                :struct t 
     465                :pkg t 
     466                :istruct t 
     467                :ratio t 
     468                :complex t 
     469                :instance t 
     470                :garrayh t 
     471                :weakh t 
     472                :poolfreelist t 
     473                :nhash t 
     474                :area t 
     475                :segment t 
     476                :dbheader t 
     477                :btree t 
     478                :class t 
     479                :load-function t)) 
    503480 
    504481(defparameter *subtype-special-copy-function* 
  • lw-branch/wood.lisp

    r3 r6  
    88;; in the file "load-wood.lisp" 
    99;; 
     10;; Portions Copyright © 2006 Clozure Associates 
    1011;; Copyright © 1996 Digitool, Inc. 
    1112;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2324;; Modification History 
    2425;; 
     26;; 02/01/06 gz    LispWorks port 
    2527;; -------------  0.961 
    2628;; 09/20/96 bill  resignal the error in the handler-case if not a wrong fasl version error 
     
    4042(in-package :cl-user) 
    4143 
     44#+ccl 
    4245(labels ((load-it () 
    4346           (let* ((path (or *load-pathname* *loading-file-source-file*)) 
     
    4750                                  :directory  (pathname-directory path) 
    4851                                  :name       "load-wood" 
    49                                   :defaults   nil))) 
     52                                  :defaults    nil))) 
    5053             (handler-case 
    5154               (compile-load load-wood-path :verbose t) 
     
    5558                  (progn 
    5659                    (format t "~&;Deleting FASL file from other MCL version...") 
    57                     (delete-file (merge-pathnames load-wood-path ccl::*.fasl-pathname*)) 
     60                    (delete-file (merge-pathnames load-wood-path 
     61                                                  ccl::*.fasl-pathname*)) 
    5862                    (return-from load-it (load-it))) 
    5963                  (error condition))))))) 
    6064  (load-it)) 
    6165                 
     66 
     67#+LispWorks 
     68(labels ((load-it () 
     69           (let* ((path (or *load-pathname*  
     70                            dspec:*source-pathname* 
     71                            system:*current-pathname*)) 
     72                  (load-wood-path 
     73                   (make-pathname :host       (pathname-host path) 
     74                                  :device     (pathname-device path) 
     75                                  :directory  (pathname-directory path) 
     76                                  :name       "load-wood"))) 
     77             (compile-file load-wood-path :verbose t :load t)))) 
     78  (load-it)) 
     79 
     80 
    6281 
    6382; Wood package is created by "load-wood.lisp" 
  • lw-branch/woodequ.lisp

    r3 r6  
    77;; Largely copied from "ccl:library;lispequ.lisp" 
    88;; 
     9;; Portions Copyright © 2006 Clozure Associates 
    910;; Copyright © 1996 Digitool, Inc. 
    1011;; Copyright © 1992-1995 Apple Computer, Inc. 
     
    2223;; Modification History 
    2324;; 
     25;; 02/01/06 gz    LispWorks port 
    2426;; -------------- 0.96 
    2527;; -------------- 0.95 
     
    5557  `(logand ,pointer -8)) 
    5658 
     59#+ccl (progn 
    5760(defconstant $t_fixnum 0) 
    5861(defconstant $t_vector 1) 
     
    6366(defconstant $t_lfun 6) 
    6467(defconstant $t_imm 7) 
     68 
     69(defconstant $dfloat_size 8) 
     70 
     71(defmacro tag-vector (&key fixnum vector symbol dfloat cons sfloat lfun imm) 
     72  (vector fixnum vector symbol dfloat cons sfloat lfun imm)) 
     73 
     74) ;#+ccl 
     75 
     76#+LispWorks (progn 
     77(defconstant $t_pos_fixnum 0) 
     78(defconstant $t_vector 1) 
     79(defconstant $t_symbol 2) 
     80(defconstant $t_dfloat 3) 
     81(defconstant $t_cons 4) 
     82(defconstant $t_neg_fixnum 5) 
     83(defconstant $t_char 6) 
     84(defconstant $t_imm 7) 
     85 
     86(defconstant $undefined-imm 0) 
     87 
     88(defmacro tag-vector (&key pos-fixnum vector symbol dfloat cons neg-fixnum char imm) 
     89  (vector pos-fixnum vector symbol dfloat cons neg-fixnum char imm)) 
     90 
     91) ;#+LispWorks 
     92 
    6593 
    6694; Non-cons cells have a header long-word for the garbage collector. 
     
    91119(defconstant $v_nlfunv 4)               ; Lisp FUNction vector 
    92120;subtype 5 unused 
     121(defconstant $v_min_arr 6) 
    93122(defconstant $v_xstr 6)      ;16-bit character vector 
    94 (defconstant $v_min_arr 7) 
    95123(defconstant $v_ubytev 7)    ;unsigned byte vector 
    96124(defconstant $v_uwordv 8)    ;unsigned word vector 
     
    112140(defconstant $v_complex 24) 
    113141(defconstant $v_instance 25) ;clos instance 
    114 ; subtypes 26, 27, 28 unused. 
     142; subtypes 26, 27, 28 unused in ccl 
     143#+LispWorks (defconstant $v_garrayh 26) 
     144#+LispWorks (defconstant $v_iarrayh 27) 
    115145(defconstant $v_weakh 29) 
    116146(defconstant $v_poolfreelist 30) 
     
    136166 
    137167(defconstant $vnodebit 5)               ; set for arrays containing pointers 
    138 (defconstant $vnode (lsh 1 $vnodebit)) 
     168(defconstant $vnode (ash 1 $vnodebit)) 
    139169 
    140170; NIL is tagged as a cons with and address of 0 
    141171(defconstant $pheap-nil $t_cons) 
     172 
     173(defmacro vtype-vector (&key unused 
     174