| 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 | (defmacro defun-inline (name arglist &body body)
|
|---|
| 9 | `(progn
|
|---|
| 10 | ;; Some implementations need this so compiler records body
|
|---|
| 11 | (declaim (inline ,name))
|
|---|
| 12 | (defun ,name ,arglist ,@body)
|
|---|
| 13 | ;; Some implementations need this because the defun wiped out previous info.
|
|---|
| 14 | (declaim (inline ,name))))
|
|---|
| 15 |
|
|---|
| 16 | #+LispWorks (editor:setup-indent "defun-inline" 2 2 2)
|
|---|
| 17 | #+LispWorks (dspec:define-dspec-alias defun-inline (name)
|
|---|
| 18 | `(defun ,name))
|
|---|
| 19 |
|
|---|
| 20 | (defun-inline neq (x y)
|
|---|
| 21 | #+ccl (ccl::neq x y)
|
|---|
| 22 | #-ccl (not (eq x y)))
|
|---|
| 23 |
|
|---|
| 24 | (defun-inline delq (x list &optional count)
|
|---|
| 25 | #+ccl (ccl::delq x list count)
|
|---|
| 26 | #-ccl (delete x list :test #'eq :count count))
|
|---|
| 27 |
|
|---|
| 28 | (defun-inline make-hash (&key weak (test 'eql) (size nil size-p))
|
|---|
| 29 | (if size-p
|
|---|
| 30 | (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test :size size)
|
|---|
| 31 | (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test)))
|
|---|
| 32 |
|
|---|
| 33 |
|
|---|
| 34 | (defun-inline ensure-simple-string (str)
|
|---|
| 35 | #+ccl (ccl::ensure-simple-string str)
|
|---|
| 36 | #-ccl (coerce str 'simple-base-string))
|
|---|
| 37 |
|
|---|
| 38 | (defun-inline classp (object)
|
|---|
| 39 | #+ccl (ccl::classp object)
|
|---|
| 40 | #-ccl (typep object 'class))
|
|---|
| 41 |
|
|---|
| 42 | (defun-inline standard-instance-p (object)
|
|---|
| 43 | #+ccl (ccl::standard-instance-p object)
|
|---|
| 44 | #+LispWorks (clos::standard-instance-p object))
|
|---|
| 45 |
|
|---|
| 46 | (defun-inline instance-class-wrapper (object)
|
|---|
| 47 | #+ccl (ccl::instance-class-wrapper object)
|
|---|
| 48 | #+LispWorks (clos::class-wrapper (class-of object)))
|
|---|
| 49 |
|
|---|
| 50 | (defun-inline class-instance-slots (object)
|
|---|
| 51 | #+ccl (ccl::class-instance-slots object)
|
|---|
| 52 | #+LispWorks (clos::class-instance-slots object))
|
|---|
| 53 |
|
|---|
| 54 | (defun-inline %set-slot-values (object slot-names slot-values)
|
|---|
| 55 | #+ccl (ccl::%set-slot-values object slot-names slot-values)
|
|---|
| 56 | #-ccl (map nil #'(lambda (name value) (setf (slot-value object name) value)) slot-names slot-values))
|
|---|
| 57 |
|
|---|
| 58 | (defun-inline array-data-and-offset (array)
|
|---|
| 59 | #+ccl (ccl::array-data-and-offset array)
|
|---|
| 60 | #-ccl (multiple-value-bind (base offset) (array-displacement array)
|
|---|
| 61 | (if base
|
|---|
| 62 | (values base offset)
|
|---|
| 63 | (values array 0))))
|
|---|
| 64 |
|
|---|
| 65 | (defun-inline stream-direction (stream)
|
|---|
| 66 | #+ccl (ccl::stream-direction stream)
|
|---|
| 67 | #-ccl (if (input-stream-p stream) (if (output-stream-p stream) :io :input) :output))
|
|---|
| 68 |
|
|---|
| 69 | (defun-inline displaced-array-p (array)
|
|---|
| 70 | #+ccl (ccl::displaced-array-p array)
|
|---|
| 71 | #-ccl (array-displacement array))
|
|---|
| 72 |
|
|---|
| 73 | (defun-inline %char-code (char)
|
|---|
| 74 | #+ccl (ccl::%char-code char)
|
|---|
| 75 | #-ccl (the fixnum (char-code (the character char))))
|
|---|
| 76 |
|
|---|
| 77 | (defun-inline %code-char (code)
|
|---|
| 78 | #+ccl (ccl::%code-char code)
|
|---|
| 79 | #-ccl (the character (code-char (the fixnum code))))
|
|---|
| 80 |
|
|---|
| 81 | ;; bitnum is always a constant
|
|---|
| 82 | (defun-inline %bitset (bitnum word)
|
|---|
| 83 | #+ccl (ccl::bitset bitnum word)
|
|---|
| 84 | #-ccl (logior (the fixnum (ash 1 bitnum)) (the fixnum word)))
|
|---|
| 85 |
|
|---|
| 86 | ;; bitnum is always a constant
|
|---|
| 87 | (defun-inline %bitclr (bitnum word)
|
|---|
| 88 | #+ccl (ccl::bitclr bitnum word)
|
|---|
| 89 | #-ccl (logandc1 (the fixnum (ash 1 bitnum)) (the fixnum word)))
|
|---|
| 90 |
|
|---|
| 91 | (defun-inline %iasr (count word)
|
|---|
| 92 | (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
|
|---|
| 93 | #+ccl (ccl::%iasr count word)
|
|---|
| 94 | #+LispWorks
|
|---|
| 95 | (the fixnum (sys:int32-to-integer (sys:int32>> (the fixnum word) (the fixnum count)))))
|
|---|
| 96 |
|
|---|
| 97 | (defun-inline %svref (vector index)
|
|---|
| 98 | #+ccl (ccl::%svref vector index)
|
|---|
| 99 | #-ccl (%%svref vector index))
|
|---|
| 100 |
|
|---|
| 101 | (defun-inline uvsize (vector)
|
|---|
| 102 | #+ccl (ccl::uvsize vector)
|
|---|
| 103 | #-ccl (if (vectorp vector)
|
|---|
| 104 | (length vector)
|
|---|
| 105 | (if (typep vector 'structure-object)
|
|---|
| 106 | (%%svlength vector)
|
|---|
| 107 | (error "Don't know how to ~s ~s" 'uvsize vector))))
|
|---|
| 108 |
|
|---|
| 109 |
|
|---|
| 110 | (defun-inline uvref (vector index)
|
|---|
| 111 | #+ccl (ccl::uvref vector index)
|
|---|
| 112 | #-ccl (if (vectorp vector)
|
|---|
| 113 | (aref vector index)
|
|---|
| 114 | (if (typep vector 'structure-object)
|
|---|
| 115 | (%%svref vector index)
|
|---|
| 116 | (error "Don't know how to ~s ~s" 'uvref vector))))
|
|---|
| 117 |
|
|---|
| 118 | (defun-inline (setf uvref) (value vector index)
|
|---|
| 119 | #+ccl (setf (ccl::uvref vector index) value)
|
|---|
| 120 | #-ccl (if (vectorp vector)
|
|---|
| 121 | (setf (aref vector index) value)
|
|---|
| 122 | (if (typep vector 'structure-object)
|
|---|
| 123 | (setf (%%svref vector index) value)
|
|---|
| 124 | (error "Don't know how to ~s ~s" '(setf uvref) vector))))
|
|---|
| 125 |
|
|---|
| 126 | #+LispWorks
|
|---|
| 127 | (defun %%svref (vector index)
|
|---|
| 128 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 129 | (type simple-vector vector) (type fixnum index))
|
|---|
| 130 | (svref vector index))
|
|---|
| 131 |
|
|---|
| 132 | #+LispWorks
|
|---|
| 133 | (defun (setf %%svref) (value vector index)
|
|---|
| 134 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 135 | (type simple-vector vector) (type fixnum index))
|
|---|
| 136 | (setf (svref vector index) value))
|
|---|
| 137 |
|
|---|
| 138 | #+LispWorks
|
|---|
| 139 | (defun %%svlength (vector)
|
|---|
| 140 | (declare (optimize (safety 0) (debug 0) (speed 3))
|
|---|
| 141 | (type simple-vector vector))
|
|---|
| 142 | (length vector))
|
|---|
| 143 |
|
|---|
| 144 | (defun-inline byte-vector-length (byte-vector)
|
|---|
| 145 | #+ccl (ccl::uvector-bytes byte-array)
|
|---|
| 146 | #-ccl (length byte-vector))
|
|---|
| 147 |
|
|---|
| 148 | (defun-inline uvector-subtype-p (obj subtype)
|
|---|
| 149 | #+ccl (ccl::uvector-subtype-p obj subtype)
|
|---|
| 150 | #-ccl (eql (uvector-subtype obj) subtype))
|
|---|
| 151 |
|
|---|
| 152 |
|
|---|
| 153 | (defun-inline byte-array-p (array)
|
|---|
| 154 | #+ccl-68k-target
|
|---|
| 155 | (and (ccl::uvectorp array)
|
|---|
| 156 | (let ((subtype (ccl::%vect-subtype array)))
|
|---|
| 157 | (or (eql subtype ccl::$v_sstr)
|
|---|
| 158 | (eql subtype ccl::$v_ubytev)
|
|---|
| 159 | (eql subtype ccl::$v_sbytev))))
|
|---|
| 160 | #+ppc-target
|
|---|
| 161 | (let ((typecode (ccl::extract-typecode array)))
|
|---|
| 162 | (or (eql typecode ppc::subtag-simple-base-string)
|
|---|
| 163 | (eql typecode ppc::subtag-s8-vector)
|
|---|
| 164 | (eql typecode ppc::subtag-u8-vector)))
|
|---|
| 165 | #+Lispworks
|
|---|
| 166 | (and (typep array 'simple-array)
|
|---|
| 167 | (let ((type (array-element-type array)))
|
|---|
| 168 | (or (eq type 'base-char)
|
|---|
| 169 | (equal type '(signed-byte 8))
|
|---|
| 170 | (equal type '(unsigned-byte 8))))))
|
|---|
| 171 |
|
|---|
| 172 |
|
|---|
| 173 | (defun-inline ensure-byte-array (array)
|
|---|
| 174 | ;; There is just no way to make this fast in LispWorks.
|
|---|
| 175 | #-LispWorks
|
|---|
| 176 | (unless (byte-array-p array)
|
|---|
| 177 | (error "~s is not a byte array" array))
|
|---|
| 178 | array)
|
|---|
| 179 |
|
|---|
| 180 | #+LispWorks
|
|---|
| 181 | (eval-when (:execute :compile-toplevel :load-toplevel)
|
|---|
| 182 |
|
|---|
| 183 | (defun %copy-as-byte-vector (from from-offset to to-offset len)
|
|---|
| 184 | (declare (optimize (safety 0) (speed 3) (debug 0))
|
|---|
| 185 | (type fixnum from-offset to-offset len))
|
|---|
| 186 | ;(unless (and (typep from 'simple-array) (typep to 'simple-array))
|
|---|
| 187 | ; (error "Invalid array to copy: ~s" (if (typep from 'simple-array) to from)))
|
|---|
| 188 | (let ((from from) (to to))
|
|---|
| 189 | (declare (type (simple-array (unsigned-byte 8) (*)) from to))
|
|---|
| 190 | (if (and (eq from to) (< from-offset to-offset))
|
|---|
| 191 | (loop for i fixnum from 0 below len
|
|---|
| 192 | for from-i fixnum downfrom (+ from-offset (the fixnum (1- len)))
|
|---|
| 193 | for to-i fixnum downfrom (+ to-offset (the fixnum (1- len)))
|
|---|
| 194 | do (setf (aref from to-i) (aref from from-i)))
|
|---|
| 195 | (loop for i fixnum from 0 below len
|
|---|
| 196 | for from-i fixnum upfrom from-offset
|
|---|
| 197 | for to-i fixnum upfrom to-offset
|
|---|
| 198 | do (setf (aref to to-i) (aref from from-i))))))
|
|---|
| 199 |
|
|---|
| 200 |
|
|---|
| 201 | ;; The first byte of a float-vector is at (aref (the byte-vector float-vector) $floatv-read-offset)
|
|---|
| 202 | ;; $floatv-read-offset may be positive or negative.
|
|---|
| 203 | (defconstant $floatv-read-offset (let* ((farr (make-array 3 :element-type 'double-float))
|
|---|
| 204 | (barr (make-array 8 :element-type '(unsigned-byte 8))))
|
|---|
| 205 | (unless (compiled-function-p #'%copy-as-byte-vector)
|
|---|
| 206 | (compile '%copy-as-byte-vector))
|
|---|
| 207 | (fill farr 0.0d0)
|
|---|
| 208 | (setf (aref farr 1) 7.7d70)
|
|---|
| 209 | (fill barr 0)
|
|---|
| 210 | (%copy-as-byte-vector farr 8 barr 0 8)
|
|---|
| 211 | (if (zerop (aref barr 7))
|
|---|
| 212 | (- (position-if-not #'zerop barr :from-end t) 8)
|
|---|
| 213 | (position-if-not #'zerop barr))))
|
|---|
| 214 |
|
|---|
| 215 | ;; The first byte of a double-float is at (aref (the byte-vector float) $float-read-offset)
|
|---|
| 216 | ;; $float-read-offset may be positive or negative.
|
|---|
| 217 | (defconstant $float-read-offset (let* ((barr (make-array 8 :element-type '(unsigned-byte 8)))
|
|---|
| 218 | (farr (make-array 1 :element-type 'double-float))
|
|---|
| 219 | (bytes (make-array 8 :element-type '(unsigned-byte 8))))
|
|---|
| 220 | (setf (aref farr 0) 7.7d70)
|
|---|
| 221 | (%copy-as-byte-vector farr $floatv-read-offset bytes 0 8)
|
|---|
| 222 | (loop for i from 0 below 16
|
|---|
| 223 | do (%copy-as-byte-vector 7.7d70 i barr 0 8)
|
|---|
| 224 | when (equalp barr bytes) return i
|
|---|
| 225 | do (%copy-as-byte-vector 7.7d70 (- i) barr 0 8)
|
|---|
| 226 | when (equalp barr bytes) return (- i)
|
|---|
| 227 | finally (error "Can't find float-read-offset"))))
|
|---|
| 228 |
|
|---|
| 229 | );+lispworks eval-when
|
|---|
| 230 |
|
|---|
| 231 | (defun-inline copy-as-byte-vector (from from-offset to to-offset len)
|
|---|
| 232 | #+ccl (ccl::%copy-ivector-to-ivector from from-offset to to-offset len)
|
|---|
| 233 | #-ccl (%copy-as-byte-vector from from-offset to to-offset len))
|
|---|
| 234 |
|
|---|
| 235 |
|
|---|
| 236 | (defun parse-body (body env &optional whatever)
|
|---|
| 237 | #+ccl (ccl::parse-body body env huh)
|
|---|
| 238 | #-ccl (let ((decls nil))
|
|---|
| 239 | env whatever
|
|---|
| 240 | (loop
|
|---|
| 241 | (unless (and (consp body)
|
|---|
| 242 | (consp (car body))
|
|---|
| 243 | (eq (caar body) 'declare))
|
|---|
| 244 | (return))
|
|---|
| 245 | (push (pop body) decls))
|
|---|
| 246 | (values body (nreverse decls))))
|
|---|
| 247 |
|
|---|
| 248 | (defun register-lisp-cleanup-function (fn)
|
|---|
| 249 | #+ccl (pushnew fn ccl::*lisp-cleanup-functions*)
|
|---|
| 250 | #+LispWorks (lw:define-action "When quitting image" fn fn))
|
|---|
| 251 |
|
|---|
| 252 | #-ccl (defparameter *blank-page* (make-string 512 :element-type 'base-character :initial-element #\Null))
|
|---|
| 253 |
|
|---|
| 254 | (defun extend-file-length (stream new-length)
|
|---|
| 255 | #+ccl (file-length stream new-length)
|
|---|
| 256 | #-ccl (let ((pos (file-position stream)))
|
|---|
| 257 | (file-position stream :end)
|
|---|
| 258 | (loop with page = *blank-page* with page-size = (length page)
|
|---|
| 259 | for count from (- new-length (file-length stream)) above 0 by page-size
|
|---|
| 260 | do (write-string page stream :end (min count page-size)))
|
|---|
| 261 | (file-position stream pos)
|
|---|
| 262 | new-length))
|
|---|
| 263 |
|
|---|
| 264 |
|
|---|
| 265 | #+Lispworks
|
|---|
| 266 | (progn
|
|---|
| 267 | (defun find-unbound-variable-marker ()
|
|---|
| 268 | (declare (optimize (safety 0) (debug 0) (speed 3)) (special |some unbound variable|))
|
|---|
| 269 | |some unbound variable|)
|
|---|
| 270 | (eval-when (:execute)
|
|---|
| 271 | (unless (compiled-function-p #'find-unbound-variable-marker)
|
|---|
| 272 | (compile 'find-unbound-variable-marker)))
|
|---|
| 273 | ) ;#+LispWorks
|
|---|
| 274 |
|
|---|
| 275 | (defmacro %unbound-marker ()
|
|---|
| 276 | #+ccl(ccl::%unbound-marker-8)
|
|---|
| 277 | #+LispWorks '(find-unbound-variable-marker))
|
|---|
| 278 |
|
|---|
| 279 | #-ccl
|
|---|
| 280 | (defun-inline require-type (value type)
|
|---|
| 281 | (if (typep value type)
|
|---|
| 282 | value
|
|---|
| 283 | (error "~s is not of type ~s" value type)))
|
|---|
| 284 |
|
|---|
| 285 | #-ccl
|
|---|
| 286 | (defun-inline memq (value list)
|
|---|
| 287 | (member value list :test #'eq))
|
|---|
| 288 |
|
|---|
| 289 | ;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 290 | ;;;
|
|---|
| 291 | ;;; WITH-EGC macro can disable EGC while dumping or loading.
|
|---|
| 292 | ;;; This prevents extraneous rehashing of the mem->pheap hash table
|
|---|
| 293 | ;;;
|
|---|
| 294 |
|
|---|
| 295 | (defmacro with-egc (state &body body)
|
|---|
| 296 | #+ccl
|
|---|
| 297 | (let ((egc-state (gensym)))
|
|---|
| 298 | `(let ((,egc-state (ccl:egc-enabled-p)))
|
|---|
| 299 | (unwind-protect
|
|---|
| 300 | (progn
|
|---|
| 301 | (ccl:egc ,state)
|
|---|
| 302 | ,@body)
|
|---|
| 303 | (ccl:egc ,egc-state))))
|
|---|
| 304 | #-ccl `(progn ,state ,@body))
|
|---|
| 305 |
|
|---|
| 306 |
|
|---|
| 307 | ;; (stream-read-bytes stream address vector offset length)
|
|---|
| 308 | ;; read length bytes into vector at offset from stream at address.
|
|---|
| 309 | ;;
|
|---|
| 310 | ;; (stream-write-bytes stream address vector offset length)
|
|---|
| 311 | ;; write length bytes from stream at address into vector at offset.
|
|---|
| 312 | ;; Extend the length of the file if necessary.
|
|---|
| 313 | ;;
|
|---|
| 314 | ;; (set-minimum-file-length stream length)
|
|---|
| 315 | ;; Set the file length of stream to >= length.
|
|---|
| 316 | ;;
|
|---|
| 317 | ;; Only vectors of following type need to be supported:
|
|---|
| 318 | ;; (array (unsigned-byte 8)), (array (signed-byte 8)), or simple-string
|
|---|
| 319 |
|
|---|
| 320 |
|
|---|
| 321 | #-ccl
|
|---|
| 322 | (defun stream-read-bytes (stream address vector offset length)
|
|---|
| 323 | ;(FORMAT *TRACE-OUTPUT* "~&Read x~x bytes at x~x into offset ~x" length address offset)
|
|---|
| 324 | (file-position stream address)
|
|---|
| 325 | (let ((position (read-sequence vector stream :start offset :end (+ offset length))))
|
|---|
| 326 | (- position offset)))
|
|---|
| 327 |
|
|---|
| 328 | #-ccl
|
|---|
| 329 | (defun stream-write-bytes (stream address vector offset length)
|
|---|
| 330 | ;(FORMAT *TRACE-OUTPUT* "~&Write x~x bytes at x~x from offset ~x" length address offset)
|
|---|
| 331 | (file-position stream address)
|
|---|
| 332 | (write-sequence vector stream :start offset :end (+ offset length)))
|
|---|
| 333 |
|
|---|
| 334 | #-ccl
|
|---|
| 335 | (defun set-minimum-file-length (stream length)
|
|---|
| 336 | (unless (>= (file-length stream) length)
|
|---|
| 337 | (extend-file-length stream length)))
|
|---|
| 338 |
|
|---|
| 339 |
|
|---|
| 340 | #-ccl ;; *** TODO: noop for now.
|
|---|
| 341 | (defmacro with-databases-locked (&body body)
|
|---|
| 342 | `(progn ,@body))
|
|---|
| 343 |
|
|---|
| 344 |
|
|---|
| 345 | #-ccl ;; *** TODO: noop for now.
|
|---|
| 346 | (defmacro with-databases-unlocked (&body body)
|
|---|
| 347 | `(progn ,@body))
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
