-;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*-
+;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: June 2003
;;;;
-;;;; $Id$
-;;;;
;;;; Works for CMUCL, SBCL, and AllergoCL only
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg
(in-package #:kmrcl)
-;; Intial CMUCL version by OnShored. Ported to SBCL by Kevin Rosenberg
+;; Intial CMUCL version by OnShored. Ported to AllegroCL, SBCL by Kevin Rosenberg
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:without-package-locks
- (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL"))
- (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
- (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
- (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
- sb-vm:n-byte-bits
- 1))))
+ (sb-ext:without-package-locks
+ (defvar *system-copy-fn* (intern "SYSTEM-AREA-UB8-COPY" "SB-KERNEL"))
+ (defconstant +system-copy-multiplier+
+ (if (fboundp (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ sb-vm:n-byte-bits
+ 1)))))
#+(or cmu sbcl)
(progn
(replace result (slot-value stream 'excl::buffer))
result))
- (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
- need action)
- (declare (ignore action))
- (let* ((len (file-position stream))
- (new-len (max (+ len need) (* 2 len)))
- (old-buf (slot-value stream 'excl::buffer))
- (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
- (declare (fixnum len)
- (optimize (speed 3) (safety 0)))
- (dotimes (i len)
- (setf (aref new-buf i) (aref old-buf i)))
- (setf (slot-value stream 'excl::buffer) new-buf)
- (setf (slot-value stream 'excl::buffer-ptr) new-len)
- )
- t)
+ (excl::without-package-locks
+ (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
+ need action)
+ (declare (ignore action))
+ (let* ((len (file-position stream))
+ (new-len (max (+ len need) (* 2 len)))
+ (old-buf (slot-value stream 'excl::buffer))
+ (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
+ (declare (fixnum len)
+ (optimize (speed 3) (safety 0)))
+ (dotimes (i len)
+ (setf (aref new-buf i) (aref old-buf i)))
+ (setf (slot-value stream 'excl::buffer) new-buf)
+ (setf (slot-value stream 'excl::buffer-ptr) new-len)
+ )
+ t))
)
(end (length buffer)))
(excl:make-buffer-input-stream buffer start end :octets))
) ;; progn
-
-