source: branches/lispworks/compat.lisp@ 41

;;;-*- Mode: Lisp; Package: WOOD -*-
;;;
;;; Copyright © 2006 Clozure Associates
;;;

(in-package :wood)

(defmacro defun-inline (name arglist &body body)
  `(progn
     ;; Some implementations need this so compiler records body
     (declaim (inline ,name))
     (defun ,name ,arglist ,@body)
     ;; Some implementations need this because the defun wiped out previous info.
     (declaim (inline ,name))))

#+LispWorks (editor:setup-indent "defun-inline" 2 2 2)
#+LispWorks (dspec:define-dspec-alias defun-inline (name) 
              `(defun ,name))

(defun-inline neq (x y)
  #+ccl (ccl::neq x y)
  #-ccl (not (eq x y)))

(defun-inline delq (x list &optional count)
  #+ccl (ccl::delq x list count)
  #-ccl (delete x list :test #'eq :count count))

(defun-inline make-hash (&key weak (test 'eql) (size nil size-p))
  (if size-p
    (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test :size size)
    (make-hash-table #+ccl :weak #+Lispworks :weak-kind weak :test test)))


(defun-inline ensure-simple-string (str)
  #+ccl (ccl::ensure-simple-string str)
  #-ccl (coerce str 'simple-base-string))

(defun-inline classp (object)
  #+ccl (ccl::classp object)
  #-ccl (typep object 'class))

(defun-inline standard-instance-p (object)
  #+ccl (ccl::standard-instance-p object)
  #+LispWorks (clos::standard-instance-p object))

(defun-inline instance-class-wrapper (object)
  #+ccl (ccl::instance-class-wrapper object)
  #+LispWorks (clos::class-wrapper (class-of object)))

(defun-inline class-instance-slots (object)
  #+ccl (ccl::class-instance-slots object)
  #+LispWorks (clos::class-instance-slots object))

(defun-inline %set-slot-values (object slot-names slot-values)
  #+ccl (ccl::%set-slot-values object slot-names slot-values)
  #-ccl (map nil #'(lambda (name value) (setf (slot-value object name) value)) slot-names slot-values))

(defun-inline array-data-and-offset (array)
  #+ccl (ccl::array-data-and-offset array)
  #-ccl (multiple-value-bind (base offset) (array-displacement array)
          (if base
            (values base offset)
            (values array 0))))

(defun-inline stream-direction (stream)
  #+ccl (ccl::stream-direction stream)
  #-ccl (if (input-stream-p stream) (if (output-stream-p stream) :io :input) :output))

(defun-inline displaced-array-p (array)
  #+ccl (ccl::displaced-array-p array)
  #-ccl (array-displacement array))

(defun-inline %char-code (char)
  #+ccl (ccl::%char-code char)
  #-ccl (the fixnum (char-code (the character char))))

(defun-inline %code-char (code)
  #+ccl (ccl::%code-char code)
  #-ccl (the character (code-char (the fixnum code))))

;; bitnum is always a constant
(defun-inline %bitset (bitnum word)
  #+ccl (ccl::bitset bitnum word)
  #-ccl (logior (the fixnum (ash 1 bitnum)) (the fixnum word)))

;; bitnum is always a constant
(defun-inline %bitclr (bitnum word)
  #+ccl (ccl::bitclr bitnum word)
  #-ccl (logandc1 (the fixnum (ash 1 bitnum)) (the fixnum word)))

(defun-inline %iasr (count word)
  (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
  #+ccl (ccl::%iasr count word)
  #+LispWorks
  (the fixnum (sys:int32-to-integer (sys:int32>> (the fixnum word) (the fixnum count)))))

(defun-inline %svref (vector index)
  #+ccl (ccl::%svref vector index)
  #-ccl (%%svref vector index))

(defun-inline uvsize (vector)
  #+ccl (ccl::uvsize vector)
  #-ccl (if (vectorp vector)
          (length vector)
          (if (typep vector 'structure-object)
            (%%svlength vector)
            (error "Don't know how to ~s ~s" 'uvsize vector))))


(defun-inline uvref (vector index)
  #+ccl (ccl::uvref vector index)
  #-ccl (if (vectorp vector)
          (aref vector index)
          (if (typep vector 'structure-object)
            (%%svref vector index)
            (error "Don't know how to ~s ~s" 'uvref vector))))

(defun-inline (setf uvref) (value vector index)
  #+ccl (setf (ccl::uvref vector index) value)
  #-ccl (if (vectorp vector)
          (setf (aref vector index) value)
          (if (typep vector 'structure-object)
            (setf (%%svref vector index) value)
            (error "Don't know how to ~s ~s" '(setf uvref) vector))))

#+LispWorks
(defun %%svref (vector index)
  (declare (optimize (safety 0) (debug 0) (speed 3))
           (type simple-vector vector) (type fixnum index))
  (svref vector index))

#+LispWorks
(defun (setf %%svref) (value vector index)
  (declare (optimize (safety 0) (debug 0) (speed 3))
           (type simple-vector vector) (type fixnum index))
  (setf (svref vector index) value))

#+LispWorks
(defun %%svlength (vector)
  (declare (optimize (safety 0) (debug 0) (speed 3))
           (type simple-vector vector))
  (length vector))

(defun-inline byte-vector-length (byte-vector)
  #+ccl (ccl::uvector-bytes byte-array)
  #-ccl (length byte-vector))

(defun-inline uvector-subtype-p (obj subtype)
  #+ccl (ccl::uvector-subtype-p obj subtype)
  #-ccl (eql (uvector-subtype obj) subtype))


(defun-inline byte-array-p (array)
  #+ccl-68k-target
  (and (ccl::uvectorp array)
       (let ((subtype (ccl::%vect-subtype array)))
         (or (eql subtype ccl::$v_sstr)
             (eql subtype ccl::$v_ubytev)
             (eql subtype ccl::$v_sbytev))))
  #+ppc-target
  (let ((typecode (ccl::extract-typecode array)))
    (or (eql typecode ppc::subtag-simple-base-string)
        (eql typecode ppc::subtag-s8-vector)
        (eql typecode ppc::subtag-u8-vector)))
  #+Lispworks
  (and (typep array 'simple-array)
       (let ((type (array-element-type array)))
         (or (eq type 'base-char)
             (equal type '(signed-byte 8))
             (equal type '(unsigned-byte 8))))))


(defun-inline ensure-byte-array (array)
  ;; There is just no way to make this fast in LispWorks.
  #-LispWorks
  (unless (byte-array-p array)
    (error "~s is not a byte array" array))
  array)

#+LispWorks
(eval-when (:execute :compile-toplevel :load-toplevel)

(defun %copy-as-byte-vector (from from-offset to to-offset len)
  (declare (optimize (safety 0) (speed 3) (debug 0))
           (type fixnum from-offset to-offset len))
  ;(unless (and (typep from 'simple-array) (typep to 'simple-array))
  ;  (error "Invalid array to copy: ~s"  (if (typep from 'simple-array) to from)))
  (let ((from from) (to to))
    (declare (type (simple-array (unsigned-byte 8) (*)) from to))
    (if (and (eq from to) (< from-offset to-offset))
      (loop for i fixnum from 0 below len
            for from-i fixnum downfrom (+ from-offset (the fixnum (1- len)))
            for   to-i fixnum downfrom (+ to-offset (the fixnum (1- len)))
            do (setf (aref from to-i) (aref from from-i)))
      (loop for i fixnum from 0 below len
            for from-i fixnum upfrom from-offset
            for   to-i fixnum upfrom to-offset
            do (setf (aref to to-i) (aref from from-i))))))


;; The first byte of a float-vector is at (aref (the byte-vector float-vector) $floatv-read-offset)
;; $floatv-read-offset may be positive or negative.
(defconstant $floatv-read-offset (let* ((farr (make-array 3 :element-type 'double-float))
                                        (barr (make-array 8 :element-type '(unsigned-byte 8))))
                                   (unless (compiled-function-p #'%copy-as-byte-vector)
                                     (compile '%copy-as-byte-vector))
                                   (fill farr 0.0d0)
                                   (setf (aref farr 1) 7.7d70)
                                   (fill barr 0)
                                   (%copy-as-byte-vector farr 8 barr 0 8)
                                   (if (zerop (aref barr 7))
                                     (- (position-if-not #'zerop barr :from-end t) 8)
                                     (position-if-not #'zerop barr))))

;; The first byte of a double-float is at (aref (the byte-vector float) $float-read-offset)
;; $float-read-offset may be positive or negative.
(defconstant $float-read-offset (let* ((barr (make-array 8 :element-type '(unsigned-byte 8)))
                                       (farr (make-array 1 :element-type 'double-float))
                                       (bytes (make-array 8 :element-type '(unsigned-byte 8))))
                                  (setf (aref farr 0) 7.7d70)
                                  (%copy-as-byte-vector farr $floatv-read-offset bytes 0 8)
                                  (loop for i from 0 below 16
                                        do (%copy-as-byte-vector 7.7d70 i barr 0 8)
                                        when (equalp barr bytes) return i
                                        do (%copy-as-byte-vector 7.7d70 (- i) barr 0 8)
                                        when (equalp barr bytes) return (- i)
                                        finally (error "Can't find float-read-offset"))))

);+lispworks eval-when

(defun-inline copy-as-byte-vector (from from-offset to to-offset len)
  #+ccl (ccl::%copy-ivector-to-ivector from from-offset to to-offset len)
  #-ccl (%copy-as-byte-vector from from-offset to to-offset len))


(defun parse-body (body env &optional whatever)
  #+ccl (ccl::parse-body body env huh)
  #-ccl (let ((decls nil))
          env whatever
          (loop
           (unless (and (consp body)
                        (consp (car body))
                        (eq (caar body) 'declare))
             (return))
           (push (pop body) decls))
          (values body (nreverse decls))))

(defun register-lisp-cleanup-function (fn)
  #+ccl (pushnew fn ccl::*lisp-cleanup-functions*)
  #+LispWorks (lw:define-action "When quitting image" fn fn))

#-ccl (defparameter *blank-page* (make-string 512 :element-type 'base-character :initial-element #\Null))

(defun extend-file-length (stream new-length)
  #+ccl (file-length stream new-length)
  #-ccl (let ((pos (file-position stream)))
          (file-position stream :end)
          (loop with page = *blank-page* with page-size = (length page)
                for count from (- new-length (file-length stream)) above 0 by page-size
                do (write-string page stream :end (min count page-size)))
          (file-position stream pos)
          new-length))


#+Lispworks
(progn
(defun find-unbound-variable-marker ()
  (declare (optimize (safety 0) (debug 0) (speed 3)) (special |some unbound variable|))
  |some unbound variable|)
(eval-when (:execute)
  (unless (compiled-function-p #'find-unbound-variable-marker)
    (compile 'find-unbound-variable-marker)))
) ;#+LispWorks

(defmacro %unbound-marker ()
  #+ccl(ccl::%unbound-marker-8)
  #+LispWorks '(find-unbound-variable-marker))

#-ccl
(defun-inline require-type (value type)
  (if (typep value type)
    value
    (error "~s is not of type ~s" value type)))

#-ccl
(defun-inline memq (value list)
  (member value list :test #'eq))

;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; WITH-EGC macro can disable EGC while dumping or loading.
;;; This prevents extraneous rehashing of the mem->pheap hash table
;;;

(defmacro with-egc (state &body body)
  #+ccl
  (let ((egc-state (gensym)))
    `(let ((,egc-state (ccl:egc-enabled-p)))
       (unwind-protect
         (progn
           (ccl:egc ,state)
           ,@body)
         (ccl:egc ,egc-state))))
  #-ccl `(progn ,state ,@body))


;; (stream-read-bytes stream address vector offset length)
;;   read length bytes into vector at offset from stream at address.
;;
;; (stream-write-bytes stream address vector offset length)
;;   write length bytes from stream at address into vector at offset.
;;   Extend the length of the file if necessary.
;;
;; (set-minimum-file-length stream length)
;;   Set the file length of stream to >= length.
;;
;; Only vectors of following type need to be supported:
;; (array (unsigned-byte 8)), (array (signed-byte 8)), or simple-string


#-ccl
(defun stream-read-bytes (stream address vector offset length)
  ;(FORMAT *TRACE-OUTPUT* "~&Read x~x bytes at x~x into offset ~x" length address offset)
  (file-position stream address)
  (let ((position (read-sequence vector stream :start offset :end (+ offset length))))
    (- position offset)))

#-ccl
(defun stream-write-bytes (stream address vector offset length)
  ;(FORMAT *TRACE-OUTPUT* "~&Write x~x bytes at x~x from offset ~x" length address offset)
  (file-position stream address)
  (write-sequence vector stream :start offset :end (+ offset length)))

#-ccl
(defun set-minimum-file-length (stream length)
  (unless (>= (file-length stream) length)
    (extend-file-length stream length)))


#-ccl ;; *** TODO: noop for now.
(defmacro with-databases-locked (&body body)
  `(progn ,@body))


#-ccl ;; *** TODO: noop for now.
(defmacro with-databases-unlocked (&body body)
  `(progn ,@body))