close Warning: Error with navigation contributor "AccountModule"

Changeset 6


Ignore:
Timestamp:
Sep 28, 2007, 7:04:51 PM (11 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                             (bignum unused) (badptr unused) (nlfunv unused)
     175                             (xstr unused) (ubytev unused) (uwordv unused)
     176                             (floatv unused) (slongv unused) (ulongv unused)
     177                             (bitv unused) (sbytev unused) (swordv unused)
     178                             (sstr unused) (genv unused) (arrayh unused)
     179                             (struct unused) (pkg unused) (istruct unused)
     180                             (ratio unused) (complex unused) (instance unused)
     181                             (weakh unused) (poolfreelist unused) (nhash unused)
     182                             ;; Simple-arrays other than special vectors above
     183                             (garrayh unused) (iarrayh unused)
     184                             ;; internal subtypes
     185                             area segment random-bits dbheader segment-headers
     186                             btree btree-node class load-function pload-barrier)
     187  (vector unused          ; 0 - unused
     188          bignum          ; 1 - $v_bignum
     189          unused          ; 2 - $v_macptr - not supported
     190          badptr          ; 3 - $v_badptr
     191          nlfunv          ; 4 - $v_nlfunv
     192          unused          ; 5 - unused
     193          xstr            ; 6 - $v_xstr - extended string
     194          ubytev          ; 7 - $v_ubytev - unsigned byte vector
     195          uwordv          ; 8 - $v_uwordv - unsigned word vector
     196          floatv          ; 9 - $v_floatv - float vector
     197          slongv          ; 10 - $v_slongv - Signed long vector
     198          ulongv          ; 11 - $v_ulongv - Unsigned long vector
     199          bitv            ; 12 - $v_bitv - Bit vector (handled specially)
     200          sbytev          ; 13 - $v_sbytev - Signed byte vector
     201          swordv          ; 14 - $v_swordv - Signed word vector
     202          sstr            ; 15 - $v_sstr - simple string
     203          genv            ; 16 - $v_genv - simple general vector
     204          arrayh          ; 17 - $v_arrayh - complex array header
     205          struct          ; 18 - $v_struct - structure
     206          unused          ; 19 - $v_mark - buffer mark unimplemented
     207          pkg             ; 20 - $v_pkg
     208          unused          ; 21 - unused
     209          istruct         ; 22 - $v_istruct - type in first element
     210          ratio           ; 23 - $v_ratio