File: zlib-cmucl.lisp

package info (click to toggle)
cl-pdf 166-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 1,520 kB
  • ctags: 639
  • sloc: lisp: 6,902; makefile: 39
file content (60 lines) | stat: -rw-r--r-- 1,988 bytes parent folder | download | duplicates (2)
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
;;;
;;; Copyright (c) 2002 Edi Weitz <edi@agharta.de>
;;;
;;; zlib-cmucl.lisp - Code to compress a Lisp string to an array of
;;; bytes, using the zlib compression library (http://www.zlib.org). 
;;;
;;; Usage:
;;;
;;; 1. Set *libgz-path* to the location of the zlib library on your
;;; machine. Compile and load this file
;;;
;;; 2. Call (COMPRESS-STRING "your string"). Two values are returned:
;;; the array of bytes containing the compressed data, and the
;;; actual number of bytes in the compressed output. The length of the 
;;; resulting array is a fixed function of the length of the input
;;; string, while the length of the compressed data is variable and
;;; depends on the randomness of the input (strings with a lot of
;;; repetitions will compress better).
;;;

(in-package :pdf)

#-CMU (error "This code should be loaded in CMUCL.")

(use-package "ALIEN")
(use-package "C-CALL")

(defvar *libgz-path* "/usr/lib/libz.so.1"
  "Set this variable to point to the location of the zlib library on
your system.")

(defvar *libgz-loaded* nil)

(unless *libgz-loaded*
  (load-foreign *libgz-path*):q
  (setq *libgz-loaded* t))

(declaim (inline gz-string))
(def-alien-routine ("compress" gz-string)
    integer
  (dest (* (unsigned 8))) 
  (destlen long :in-out)
  (source c-string)
  (sourcelen long))

(defun compress-string (source)
  "Compress the string SOURCE. Returns two values: the array of bytes
representing the compressed data and the number of compressed bytes."
  (let* ((sourcelen (length source))
	 (destlen (+ 12 (ceiling (* sourcelen 1.05))))
	 (dest (make-array destlen
                           :element-type '(unsigned-byte 8)
			   :initial-element 0)))
    (multiple-value-bind (res new-destlen)
        (gz-string (system:vector-sap dest)
                   destlen source sourcelen)
      (if (zerop res)
          (values (map 'string #'code-char (subseq dest 0 new-destlen))
                  new-destlen)
          (error "zlib error, code ~d" res)))))