/usr/share/common-lisp/source/clsql/sql/cmucl-compat.lisp is in cl-sql 6.5.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: cmucl-compat.lisp
;;;; Purpose: Compatiblity library for CMUCL functions
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:cl-user)
(defpackage #:cmucl-compat
(:use #:common-lisp)
(:export
#:shrink-vector
#:make-sequence-of-type
#:result-type-or-lose
#:required-argument
))
(in-package #:cmucl-compat)
#+(or cmu scl)
(defmacro required-argument ()
`(ext:required-argument))
#-(or cmu scl)
(defun required-argument ()
(error "~&A required keyword argument was not supplied"))
#+(or cmu scl)
(defmacro shrink-vector (vec len)
`(lisp::shrink-vector ,vec ,len))
#+sbcl
(defmacro shrink-vector (vec len)
`(sb-kernel::shrink-vector ,vec ,len))
#-(or cmu sbcl scl)
(defmacro shrink-vector (vec len)
"Shrinks a vector. Optimized if vector has a fill pointer.
Needs to be a macro to overwrite value of VEC."
(let ((new-vec (gensym)))
`(cond
((adjustable-array-p ,vec)
(adjust-array ,vec ,len))
((typep ,vec 'simple-array)
(let ((,new-vec (make-array ,len :element-type
(array-element-type ,vec))))
(check-type ,len fixnum)
(locally (declare (optimize (speed 3) (safety 0) (space 0)) )
(dotimes (i ,len)
(declare (fixnum i))
(setf (aref ,new-vec i) (aref ,vec i))))
(setq ,vec ,new-vec)))
((typep ,vec 'vector)
(setf (fill-pointer ,vec) ,len)
,vec)
(t
(error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec)))
)))
#-(or cmu scl)
(defun make-sequence-of-type (type length)
"Returns a sequence of the given TYPE and LENGTH."
(make-sequence type length))
#+(or cmu scl)
(if (fboundp 'lisp::make-sequence-of-type)
(defun make-sequence-of-type (type len)
(lisp::make-sequence-of-type type len))
(defun make-sequence-of-type (type len)
(common-lisp::make-sequence-of-type type len)))
#-(or cmu scl)
(defun result-type-or-lose (type nil-ok)
(unless (or type nil-ok)
(error "NIL output type invalid for this sequence function"))
(case type
((list cons)
'list)
((string simple-string base-string simple-base-string)
'string)
(simple-vector
'simple-vector)
(vector
'vector)
(t
(error "~S is a bad type specifier for sequence functions." type))
))
#+(or cmu scl)
(defun result-type-or-lose (type nil-ok)
(lisp::result-type-or-lose type nil-ok))
|