sql/cmucl-compat.lisp

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