| 1 | ;;;-*- Mode: Lisp; Package: WOOD -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info)
|
|---|
| 4 |
|
|---|
| 5 |
|
|---|
| 6 | (in-package :wood)
|
|---|
| 7 |
|
|---|
| 8 | (defun reload ()
|
|---|
| 9 | (funcall (find-symbol "QUICKLOAD" :ql) :wood :verbose t))
|
|---|
| 10 |
|
|---|
| 11 | (defmacro defun-inline (name arglist &body body)
|
|---|
| 12 | `(progn
|
|---|
| 13 | ;; Some implementations need this so compiler records body
|
|---|
| 14 | (declaim (inline ,name))
|
|---|
| 15 | (defun ,name ,arglist ,@body)
|
|---|
| 16 | ;; Some implementations need this because the defun wiped out previous info.
|
|---|
| 17 | (declaim (inline ,name))))
|
|---|
| 18 |
|
|---|
| 19 | #+LispWorks (editor:setup-indent "defun-inline" 2 2 2)
|
|---|
| 20 | #+LispWorks (dspec:define-dspec-alias defun-inline (name)
|
|---|
| 21 | `(defun ,name))
|
|---|
| 22 |
|
|---|
| 23 | (defun-inline neq (x y)
|
|---|
| 24 | #+ccl (ccl::neq x y)
|
|---|
| 25 | #-ccl (not (eq x y)))
|
|---|
| 26 |
|
|---|
| 27 | (defun delq (x list &optional count)
|
|---|
| 28 | (delete x list :test #'eq :count count))
|
|---|
| 29 |
|
|---|
| 30 | (defun-inline make-hash (&key weak (test 'eql) (size nil size-p))
|
|---|
| 31 | (if size-p
|
|---|
| 32 | (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test :size size)
|
|---|
| 33 | (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test)))
|
|---|
| 34 |
|
|---|
| 35 |
|
|---|
| 36 | (defun-inline ensure-simple-string (str)
|
|---|
| 37 | #+ccl (ccl::ensure-simple-string str)
|
|---|
| 38 | #-ccl (coerce str 'simple-base-string))
|
|---|
| 39 |
|
|---|
| 40 | (defun-inline classp (object)
|
|---|
| 41 | #+ccl (ccl::classp object)
|
|---|
| 42 | #-ccl (typep object 'class))
|
|---|
| 43 |
|
|---|
| 44 | (defun-inline standard-instance-p (object)
|
|---|
| 45 | #+ccl (ccl::standard-instance-p object)
|
|---|
| 46 | #+LispWorks (clos::standard-instance-p object))
|
|---|
| 47 |
|
|---|
| 48 | (defun-inline instance-class-wrapper (object)
|
|---|
| 49 | #+ccl (ccl::instance-class-wrapper object)
|
|---|
| 50 | #+LispWorks (clos::class-wrapper (class-of object)))
|
|---|
| 51 |
|
|---|
| 52 | (defun-inline %set-slot-values (object slot-names slot-values)
|
|---|
| 53 | #+ccl (ccl::%set-slot-values object slot-names slot-values)
|
|---|
| 54 | #-ccl (map nil #'(lambda (name value) (setf (slot-value object name) value)) slot-names slot-values))
|
|---|
| 55 |
|
|---|
| 56 | (defun-inline array-data-and-offset (array)
|
|---|
| 57 | #+ccl (ccl::array-data-and-offset array)
|
|---|
| 58 | #-ccl (multiple-value-bind (base offset) (array-displacement array)
|
|---|
| 59 | (if base
|
|---|
| 60 | (values base offset)
|
|---|
| 61 | (values array 0))))
|
|---|
| 62 |
|
|---|
| 63 | (defun-inline stream-direction (stream)
|
|---|
| 64 | #+ccl (ccl::stream-direction stream)
|
|---|
| 65 | #-ccl (if (input-stream-p stream) (if (output-stream-p stream) :io :input) :output))
|
|---|
| 66 |
|
|---|
| 67 | (defun-inline displaced-array-p (array)
|
|---|
| 68 | #+ccl (ccl::displaced-array-p array)
|
|---|
| 69 | #-ccl (array-displacement array))
|
|---|
| 70 |
|
|---|
| 71 | (defun-inline %char-code (char)
|
|---|
| 72 | #+ccl (ccl::%char-code char)
|
|---|
| 73 | #-ccl (the fixnum (char-code (the character char))))
|
|---|
| 74 |
|
|---|
| 75 | (defun-inline %code-char (code)
|
|---|
| 76 | #+ccl (ccl::%code-char code)
|
|---|
| 77 | #-ccl (the character (code-char (the fixnum code))))
|
|---|
| 78 |
|
|---|
| 79 | ;; bitnum is always a constant
|
|---|
| 80 | (defun-inline %bitset (bitnum word)
|
|---|
| 81 | #+ccl (ccl::bitset bitnum word)
|
|---|
| 82 | #-ccl (logior (the fixnum (ash 1 bitnum)) (the fixnum word)))
|
|---|
| 83 |
|
|---|
| 84 | ;; bitnum is always a constant
|
|---|
| 85 | (defun-inline %bitclr (bitnum word)
|
|---|
| 86 | #+ccl (ccl::bitclr bitnum word)
|
|---|
| 87 | #-ccl (logandc1 (the fixnum (ash 1 bitnum)) (the fixnum word)))
|
|---|
| 88 |
|
|---|
| 89 | (defun-inline %iasr (count word)
|
|---|
| 90 | (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
|
|---|
| 91 | #+ccl (ccl::%iasr count word)
|
|---|
| 92 | #+LispWorks
|
|---|
| 93 | (the fixnum (sys:int32-to-integer (sys:int32>> (the fixnum word) (the fixnum count)))))
|
|---|
| 94 |
|
|---|
| 95 | (defun-inline %svref (vector index)
|
|---|
| 96 | #+ccl (ccl::%svref vector index)
|
|---|
| 97 | #-ccl (%%svref vector index))
|
|---|
| 98 |
|
|---|
| 99 | (defun-inline uvsize (vector)
|
|---|
| 100 | #+ccl (ccl::uvsize vector)
|
|---|
| 101 | #-ccl (if (vectorp vector)
|
|---|
| 102 | (length vector)
|
|---|
| 103 | (if (typep vector 'structure-object)
|
|---|
| 104 | (%%svlength vector)
|
|---|
| 105 | (error "Don't know how to ~s ~s" 'uvsize vector))))
|
|---|
| 106 |
|
|---|
| 107 |
|
|---|
| 108 | (defun-inline uvref (vector index)
|
|---|
| 109 | #+ccl (ccl::uvref vector index)
|
|---|
| 110 | #-ccl (if (vectorp vector)
|
|---|
| 111 | (aref vector index)
|
|---|
| 112 | (if (typep vector 'structure-object)
|
|---|
| 113 | (%%svref vector index)
|
|---|
| 114 | (error "Don't know how to ~s ~s" 'uvref vector))))
|
|---|
| 115 |
|
|---|
| 116 | (defun-inline (setf uvref) (value vector index)
|
|---|
| 117 | #+ccl (setf (ccl::uvref vector index) value)
|
|---|
| 118 | #-ccl (if (vectorp vector)
|
|---|
| 119 | (setf (aref vector index) value)
|
|---|
| 120 | (if (typep vector 'structure-object)
|
|---|
| 121 | (setf (%%svref vector index) value)
|
|---|
| 122 | (error "Don't know how to ~s ~s" '(setf uvref) vector))))
|
|---|
| 123 |
|
|---|
| 124 | #+LispWorks
|
|---|
| 125 | (defun %%svref (vector index)
|
|---|
| 126 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 127 | (type simple-vector vector) (type fixnum index))
|
|---|
| 128 | (svref vector index))
|
|---|
| 129 |
|
|---|
| 130 | #+LispWorks
|
|---|
| 131 | (defun (setf %%svref) (value vector index)
|
|---|
| 132 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 133 | (type simple-vector vector) (type fixnum index))
|
|---|
| 134 | (setf (svref vector index) value))
|
|---|
| 135 |
|
|---|
| 136 | #+LispWorks
|
|---|
| 137 | (defun %%svlength (vector)
|
|---|
| 138 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 139 | (type simple-vector vector))
|
|---|
| 140 | (length vector))
|
|---|
| 141 |
|
|---|
| 142 | (defun byte-vector-length (byte-vector)
|
|---|
| 143 | (length byte-vector))
|
|---|
| 144 |
|
|---|
| 145 | (defun uvector-subtype-p (obj subtype)
|
|---|
| 146 | #+ccl (ccl::uvector-subtype-p obj subtype)
|
|---|
| 147 | #-ccl (eql (uvector-subtype obj) subtype))
|
|---|
| 148 |
|
|---|
| 149 | (defun byte-array-p (array)
|
|---|
| 150 | (and (typep array 'simple-array)
|
|---|
| 151 | (let ((type (array-element-type array)))
|
|---|
| 152 | (or (eq type 'character)
|
|---|
| 153 | (equal type '(signed-byte 8))
|
|---|
| 154 | (equal type '(unsigned-byte 8))))))
|
|---|
| 155 |
|
|---|
| 156 |
|
|---|
| 157 | (defun ensure-byte-array (array)
|
|---|
| 158 | ;; There is just no way to make this fast in LispWorks.
|
|---|
| 159 | (unless (byte-array-p array)
|
|---|
| 160 | (error "~s is not a byte array" array))
|
|---|
| 161 | array)
|
|---|
| 162 |
|
|---|
| 163 | #+LispWorks
|
|---|
| 164 | (eval-when (:execute :compile-toplevel :load-toplevel)
|
|---|
| 165 |
|
|---|
| 166 | (defun %copy-as-byte-vector (from from-offset to to-offset len)
|
|---|
| 167 | (declare (optimize (safety 0) (speed 3) (debug 0))
|
|---|
| 168 | (type fixnum from-offset to-offset len))
|
|---|
| 169 | ;(unless (and (typep from 'simple-array) (typep to 'simple-array))
|
|---|
| 170 | ; (error "Invalid array to copy: ~s" (if (typep from 'simple-array) to from)))
|
|---|
| 171 | (let ((from from) (to to))
|
|---|
| 172 | (declare (type (simple-array (unsigned-byte 8) (*)) from to))
|
|---|
| 173 | (if (and (eq from to) (< from-offset to-offset))
|
|---|
| 174 | (loop for i fixnum from 0 below len
|
|---|
| 175 | for from-i fixnum downfrom (+ from-offset (the fixnum (1- len)))
|
|---|
| 176 | for to-i fixnum downfrom (+ to-offset (the fixnum (1- len)))
|
|---|
| 177 | do (setf (aref from to-i) (aref from from-i)))
|
|---|
| 178 | (loop for i fixnum from 0 below len
|
|---|
| 179 | for from-i fixnum upfrom from-offset
|
|---|
| 180 | for to-i fixnum upfrom to-offset
|
|---|
| 181 | do (setf (aref to to-i) (aref from from-i))))))
|
|---|
| 182 |
|
|---|
| 183 |
|
|---|
| 184 | ;; The first byte of a float-vector is at (aref (the byte-vector float-vector) $floatv-read-offset)
|
|---|
| 185 | ;; $floatv-read-offset may be positive or negative.
|
|---|
| 186 | (defconstant $floatv-read-offset (let* ((farr (make-array 3 :element-type 'double-float))
|
|---|
| 187 | (barr (make-array 8 :element-type '(unsigned-byte 8))))
|
|---|
| 188 | (unless (compiled-function-p #'%copy-as-byte-vector)
|
|---|
| 189 | (compile '%copy-as-byte-vector))
|
|---|
| 190 | (fill farr 0.0d0)
|
|---|
| 191 | (setf (aref farr 1) 7.7d70)
|
|---|
| 192 | (fill barr 0)
|
|---|
| 193 | (%copy-as-byte-vector farr 8 barr 0 8)
|
|---|
| 194 | (if (zerop (aref barr 7))
|
|---|
| 195 | (- (position-if-not #'zerop barr :from-end t) 8)
|
|---|
| 196 | (position-if-not #'zerop barr))))
|
|---|
| 197 |
|
|---|
| 198 | ;; The first byte of a double-float is at (aref (the byte-vector float) $float-read-offset)
|
|---|
| 199 | ;; $float-read-offset may be positive or negative.
|
|---|
| 200 | (defconstant $float-read-offset (let* ((barr (make-array 8 :element-type '(unsigned-byte 8)))
|
|---|
| 201 | (farr (make-array 1 :element-type 'double-float))
|
|---|
| 202 | (bytes (make-array 8 :element-type '(unsigned-byte 8))))
|
|---|
| 203 | (setf (aref farr 0) 7.7d70)
|
|---|
| 204 | (%copy-as-byte-vector farr $floatv-read-offset bytes 0 8)
|
|---|
| 205 | (loop for i from 0 below 16
|
|---|
| 206 | do (%copy-as-byte-vector 7.7d70 i barr 0 8)
|
|---|
| 207 | when (equalp barr bytes) return i
|
|---|
| 208 | do (%copy-as-byte-vector 7.7d70 (- i) barr 0 8)
|
|---|
| 209 | when (equalp barr bytes) return (- i)
|
|---|
| 210 | finally (error "Can't find float-read-offset"))))
|
|---|
| 211 |
|
|---|
| 212 | );+lispworks eval-when
|
|---|
| 213 |
|
|---|
| 214 | #+ccl
|
|---|
| 215 | (progn
|
|---|
| 216 |
|
|---|
| 217 | (defun %copy-ivector-to-ivector (from from-offset to to-offset count)
|
|---|
| 218 | "Replacement for the currently broken `ccl::%copy-ivector-to-ivector'."
|
|---|
| 219 | (declare (fixnum from-offset to-offset count)
|
|---|
| 220 | (optimize (speed 3) (safety 0)))
|
|---|
| 221 | (if (and (eq from to)
|
|---|
| 222 | (< from-offset to-offset)
|
|---|
| 223 | (> count (the fixnum (- to-offset from-offset))))
|
|---|
| 224 | (%copy-ivector-to-ivector-predecrement
|
|---|
| 225 | from (the fixnum (+ from-offset count))
|
|---|
| 226 | to (the fixnum (+ to-offset count)) count)
|
|---|
| 227 | (%copy-ivector-to-ivector-postincrement
|
|---|
| 228 | from from-offset to to-offset count)))
|
|---|
| 229 |
|
|---|
| 230 | (defun %copy-ivector-to-ivector-postincrement (from from-offset to to-offset count)
|
|---|
| 231 | (declare (type (simple-array (unsigned-byte 8) (*)) from to)
|
|---|
| 232 | (fixnum from-offset to-offset count)
|
|---|
| 233 | (optimize (speed 3) (safety 0)))
|
|---|
| 234 | (let ((fi from-offset)
|
|---|
| 235 | (ti to-offset))
|
|---|
| 236 | (declare (fixnum fi ti))
|
|---|
| 237 | (dotimes (i count)
|
|---|
| 238 | (declare (fixnum i))
|
|---|
| 239 | (setf (aref to ti) (aref from fi))
|
|---|
| 240 | (incf fi)
|
|---|
| 241 | (incf ti)))
|
|---|
| 242 | to)
|
|---|
| 243 |
|
|---|
| 244 | (defun %copy-ivector-to-ivector-predecrement (from from-offset to to-offset count)
|
|---|
| 245 | (declare (type (simple-array (unsigned-byte 8) (*)) from to)
|
|---|
| 246 | (fixnum from-offset to-offset count)
|
|---|
| 247 | (optimize (speed 3) (safety 0)))
|
|---|
| 248 | (let ((fi from-offset)
|
|---|
| 249 | (ti to-offset))
|
|---|
| 250 | (declare (fixnum fi ti))
|
|---|
| 251 | (dotimes (i count)
|
|---|
| 252 | (declare (fixnum i))
|
|---|
| 253 | (setf (aref to (decf ti)) (aref from (decf fi)))))
|
|---|
| 254 | to)
|
|---|
| 255 |
|
|---|
| 256 | (defun %copy-as-byte-vector (from from-offset to to-offset len)
|
|---|
| 257 | (cond ((simple-string-p from)
|
|---|
| 258 | (if (simple-string-p to)
|
|---|
| 259 | (%copy-ivector-to-ivector from (* 4 from-offset)
|
|---|
| 260 | to (* 4 to-offset) (* 4 len))
|
|---|
| 261 | (%copy-string-to-ivector from from-offset to to-offset len)))
|
|---|
| 262 | ((simple-string-p to)
|
|---|
| 263 | (%copy-ivector-to-string from from-offset to to-offset len))
|
|---|
| 264 | (t (%copy-ivector-to-ivector from from-offset to to-offset len))))
|
|---|
| 265 |
|
|---|
| 266 | (defun %copy-string-to-ivector (from from-offset to to-offset len)
|
|---|
| 267 | (declare (type simple-string from)
|
|---|
| 268 | (type (simple-array (unsigned-byte 8) (*)) to)
|
|---|
| 269 | (fixnum from-offset)
|
|---|
| 270 | (fixnum to-offset)
|
|---|
| 271 | (fixnum len)
|
|---|
| 272 | (optimize (speed 3) (safety 0)))
|
|---|
| 273 | (dotimes (i len)
|
|---|
| 274 | (declare (fixnum i))
|
|---|
| 275 | (let* ((ch (aref from from-offset))
|
|---|
| 276 | (code (char-code ch)))
|
|---|
| 277 | (declare (character ch) (fixnum code))
|
|---|
| 278 | (when (> code 255)
|
|---|
| 279 | (error "Non-8-bit character: ~s" ch))
|
|---|
| 280 | (setf (aref to to-offset) code))
|
|---|
| 281 | (incf from-offset)
|
|---|
| 282 | (incf to-offset)))
|
|---|
| 283 |
|
|---|
| 284 | (defun %copy-ivector-to-string (from from-offset to to-offset len)
|
|---|
| 285 | (declare (type simple-string to)
|
|---|
| 286 | (type (simple-array (unsigned-byte 8) (*)) from)
|
|---|
| 287 | (fixnum from-offset)
|
|---|
| 288 | (fixnum to-offset)
|
|---|
| 289 | (fixnum len)
|
|---|
| 290 | (optimize (speed 3) (safety 0)))
|
|---|
| 291 | (dotimes (i len)
|
|---|
| 292 | (declare (fixnum i))
|
|---|
| 293 | (let ((code (aref from from-offset)))
|
|---|
| 294 | (declare (fixnum code))
|
|---|
| 295 | (setf (aref to to-offset) (code-char code)))
|
|---|
| 296 | (incf from-offset)
|
|---|
| 297 | (incf to-offset)))
|
|---|
| 298 |
|
|---|
| 299 | ); #+ccl
|
|---|
| 300 |
|
|---|
| 301 | (defun copy-as-byte-vector (from from-offset to to-offset len)
|
|---|
| 302 | (%copy-as-byte-vector from from-offset to to-offset len))
|
|---|
| 303 |
|
|---|
| 304 |
|
|---|
| 305 | (defun parse-body (body env &optional doc-string-allowed)
|
|---|
| 306 | #+ccl (ccl::parse-body body env doc-string-allowed)
|
|---|
| 307 | #-ccl (let ((decls nil))
|
|---|
| 308 | env whatever
|
|---|
| 309 | (loop
|
|---|
| 310 | (unless (and (consp body)
|
|---|
| 311 | (consp (car body))
|
|---|
| 312 | (eq (caar body) 'declare))
|
|---|
| 313 | (return))
|
|---|
| 314 | (push (pop body) decls))
|
|---|
| 315 | (values body (nreverse decls))))
|
|---|
| 316 |
|
|---|
| 317 | (defun register-lisp-cleanup-function (fn)
|
|---|
| 318 | #+ccl (pushnew fn ccl::*lisp-cleanup-functions*)
|
|---|
| 319 | #+LispWorks (lw:define-action "When quitting image" fn fn))
|
|---|
| 320 |
|
|---|
| 321 | (defparameter *blank-page*
|
|---|
| 322 | (make-array 512
|
|---|
| 323 | :element-type '(unsigned-byte 8)
|
|---|
| 324 | :initial-element 0))
|
|---|
| 325 |
|
|---|
| 326 | (defun extend-file-length (stream new-length)
|
|---|
| 327 | (let ((pos (file-position stream)))
|
|---|
| 328 | (file-position stream :end)
|
|---|
| 329 | (loop with page = *blank-page* with page-size = (length page)
|
|---|
| 330 | for count from (- new-length (file-length stream)) above 0 by page-size
|
|---|
| 331 | do (write-sequence page stream :end (min count page-size)))
|
|---|
| 332 | (file-position stream pos)
|
|---|
| 333 | new-length))
|
|---|
| 334 |
|
|---|
| 335 |
|
|---|
| 336 | #+Lispworks
|
|---|
| 337 | (progn
|
|---|
| 338 | (defun find-unbound-variable-marker ()
|
|---|
| 339 | (declare (optimize (safety 0) (debug 0) (speed 3)) (special |some unbound variable|))
|
|---|
| 340 | |some unbound variable|)
|
|---|
| 341 | (eval-when (:execute)
|
|---|
| 342 | (unless (compiled-function-p #'find-unbound-variable-marker)
|
|---|
| 343 | (compile 'find-unbound-variable-marker)))
|
|---|
| 344 | ) ;#+LispWorks
|
|---|
| 345 |
|
|---|
| 346 | (defmacro %unbound-marker ()
|
|---|
| 347 | #+ccl(ccl::%unbound-marker-8)
|
|---|
| 348 | #+LispWorks '(find-unbound-variable-marker))
|
|---|
| 349 |
|
|---|
| 350 | (defun require-type (value type)
|
|---|
| 351 | (if (typep value type)
|
|---|
| 352 | value
|
|---|
| 353 | (error "~s is not of type ~s" value type)))
|
|---|
| 354 |
|
|---|
| 355 | (defun memq (value list)
|
|---|
| 356 | (member value list :test #'eq))
|
|---|
| 357 |
|
|---|
| 358 | (defun assq (key list)
|
|---|
| 359 | (assoc key list :test #'eq))
|
|---|
| 360 |
|
|---|
| 361 | (defun fixnump (x)
|
|---|
| 362 | (typep x 'fixnum))
|
|---|
| 363 |
|
|---|
| 364 | (defun copy-file (source-path dest-path
|
|---|
| 365 | &key (if-exists :error) (if-does-not-exist :create))
|
|---|
| 366 | #+ccl
|
|---|
| 367 | (ccl:copy-file source-path dest-path
|
|---|
| 368 | :if-exists if-exists
|
|---|
| 369 | :if-does-not-exist if-does-not-exist)
|
|---|
| 370 | #-ccl
|
|---|
| 371 | (let* ((original (truename source-path))
|
|---|
| 372 | (new-name (merge-pathnames dest-path original)))
|
|---|
| 373 | (with-open-file (in original :element-type '(unsigned-byte 8))
|
|---|
| 374 | (with-open-file (out new-name :direction :output
|
|---|
| 375 | :if-exists if-exists
|
|---|
| 376 | :if-does-not-exist if-does-not-exist
|
|---|
| 377 | :element-type '(unsigned-byte 8))
|
|---|
| 378 | (when out ;:if-exists nil
|
|---|
| 379 | (loop :with buf = (make-array 4096 :element-type '(unsigned-byte 8))
|
|---|
| 380 | :for n := (read-sequence buf in :end 4096)
|
|---|
| 381 | :until (eql n 0)
|
|---|
| 382 | :do (write-sequence buf out :end n)))))))
|
|---|
| 383 |
|
|---|
| 384 |
|
|---|
| 385 | ;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 386 | ;;;
|
|---|
| 387 | ;;; WITH-EGC macro can disable EGC while dumping or loading.
|
|---|
| 388 | ;;; This prevents extraneous rehashing of the mem->pheap hash table
|
|---|
| 389 | ;;;
|
|---|
| 390 |
|
|---|
| 391 | (defmacro with-egc (state &body body)
|
|---|
| 392 | #+ccl
|
|---|
| 393 | (let ((egc-state (gensym)))
|
|---|
| 394 | `(let ((,egc-state (ccl:egc-enabled-p)))
|
|---|
| 395 | (unwind-protect
|
|---|
| 396 | (progn
|
|---|
| 397 | (ccl:egc ,state)
|
|---|
| 398 | ,@body)
|
|---|
| 399 | (ccl:egc ,egc-state))))
|
|---|
| 400 | #-ccl `(progn ,state ,@body))
|
|---|
| 401 |
|
|---|
| 402 |
|
|---|
| 403 | ;; (stream-read-bytes stream address vector offset length)
|
|---|
| 404 | ;; read length bytes into vector at offset from stream at address.
|
|---|
| 405 | ;;
|
|---|
| 406 | ;; (stream-write-bytes stream address vector offset length)
|
|---|
| 407 | ;; write length bytes from stream at address into vector at offset.
|
|---|
| 408 | ;; Extend the length of the file if necessary.
|
|---|
| 409 | ;;
|
|---|
| 410 | ;; (set-minimum-file-length stream length)
|
|---|
| 411 | ;; Set the file length of stream to >= length.
|
|---|
| 412 | ;;
|
|---|
| 413 | ;; Only vectors of following type need to be supported:
|
|---|
| 414 | ;; (array (unsigned-byte 8)), (array (signed-byte 8)), or simple-string
|
|---|
| 415 |
|
|---|
| 416 |
|
|---|
| 417 | (defun stream-read-bytes (stream address vector offset length)
|
|---|
| 418 | ;(FORMAT *TRACE-OUTPUT* "~&Read x~x bytes at x~x into offset ~x" length address offset)
|
|---|
| 419 | (file-position stream address)
|
|---|
| 420 | (let ((position (read-sequence vector stream :start offset :end (+ offset length))))
|
|---|
| 421 | (- position offset)))
|
|---|
| 422 |
|
|---|
| 423 | (defun stream-write-bytes (stream address vector offset length)
|
|---|
| 424 | ;(FORMAT *TRACE-OUTPUT* "~&Write x~x bytes at x~x from offset ~x" length address offset)
|
|---|
| 425 | (file-position stream address)
|
|---|
| 426 | (write-sequence vector stream :start offset :end (+ offset length)))
|
|---|
| 427 |
|
|---|
| 428 | (defun set-minimum-file-length (stream length)
|
|---|
| 429 | (unless (>= (file-length stream) length)
|
|---|
| 430 | (extend-file-length stream length)))
|
|---|
| 431 |
|
|---|
| 432 |
|
|---|
| 433 | (defmacro with-databases-locked (&body body)
|
|---|
| 434 | `(progn ,@body))
|
|---|
| 435 |
|
|---|
| 436 |
|
|---|
| 437 | (defmacro with-databases-unlocked (&body body)
|
|---|
| 438 | `(progn ,@body))
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
