1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: cmucl-compat.lisp
6 ;;;; Purpose: Compatiblity library for CMUCL functions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg
14 ;;;; CLSQL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
19 (in-package #:cl-user
)
21 (defpackage #:cmucl-compat
25 #:make-sequence-of-type
29 (in-package #:cmucl-compat
)
32 (defmacro required-argument
()
33 `(ext:required-argument
))
36 (defun required-argument ()
37 (error "~&A required keyword argument was not supplied"))
40 (defmacro shrink-vector
(vec len
)
41 `(lisp::shrink-vector
,vec
,len
))
44 (defmacro shrink-vector
(vec len
)
45 `(sb-kernel::shrink-vector
,vec
,len
))
48 (defmacro shrink-vector
(vec len
)
49 "Shrinks a vector. Optimized if vector has a fill pointer.
50 Needs to be a macro to overwrite value of VEC."
51 (let ((new-vec (gensym)))
53 ((adjustable-array-p ,vec
)
54 (adjust-array ,vec
,len
))
55 ((typep ,vec
'simple-array
)
56 (let ((,new-vec
(make-array ,len
:element-type
57 (array-element-type ,vec
))))
58 (check-type ,len fixnum
)
59 (locally (declare (optimize (speed 3) (safety 0) (space 0)) )
62 (setf (aref ,new-vec i
) (aref ,vec i
))))
63 (setq ,vec
,new-vec
)))
65 (setf (fill-pointer ,vec
) ,len
)
68 (error "Unable to shrink vector ~S which is type-of ~S" ,vec
(type-of ,vec
)))
73 (defun make-sequence-of-type (type length
)
74 "Returns a sequence of the given TYPE and LENGTH."
75 (make-sequence type length
))
78 (if (fboundp 'lisp
::make-sequence-of-type
)
79 (defun make-sequence-of-type (type len
)
80 (lisp::make-sequence-of-type type len
))
81 (defun make-sequence-of-type (type len
)
82 (common-lisp::make-sequence-of-type type len
)))
85 (defun result-type-or-lose (type nil-ok
)
86 (unless (or type nil-ok
)
87 (error "NIL output type invalid for this sequence function"))
91 ((string simple-string base-string simple-base-string
)
98 (error "~S is a bad type specifier for sequence functions." type
))
102 (defun result-type-or-lose (type nil-ok
)
103 (lisp::result-type-or-lose type nil-ok
))