ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

31
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/.travis.yml Normal file
View file

@ -0,0 +1,31 @@
language: lisp
env:
matrix:
- LISP=abcl
- LISP=allegro
- LISP=sbcl
- LISP=sbcl32
- LISP=ccl
- LISP=ccl32
- LISP=clisp
- LISP=clisp32
- LISP=cmucl
- LISP=ecl
matrix:
allow_failures:
- env: LISP=cmucl
- env: LISP=ecl
install:
- curl -L https://github.com/luismbo/cl-travis/raw/master/install.sh | sh
- git clone --depth=1 git://github.com/trivial-features/trivial-features.git ~/lisp/trivial-features
- git clone https://gitlab.common-lisp.net/alexandria/alexandria.git ~/lisp/alexandria
script:
- cl -e '(ql:quickload :babel-tests)
(unless (babel-tests:run)
(uiop:quit 1))'
sudo: required

20
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/COPYRIGHT Normal file
View file

@ -0,0 +1,20 @@
Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

27
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/HEADER Normal file
View file

@ -0,0 +1,27 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; filename --- description
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

34
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/NOTES Normal file
View file

@ -0,0 +1,34 @@
======================================
LIST OF IDEAS AND TODO ITEMS FOR BABEL
* VERY IMPORTANT: given that we steal a lot of code from OpenMCL we
probably to license those files under the LLGPL (or is it the
whole library?) Figure this out ASAP.
* Many more tests needed.
- test invalid sequences.
- use more interesting test files.
- test with big strings that when converted would need a array
with more than array-index-limit elements.
* Add support for ennforcing endiannes for multi-byte encodings like
UTF-16 and UTF-32.
* Implement more encodings. (ISO-8859-*, windows, CJK encodings, etc)
* null-termination, bom-markers. Add to string-to-octets.
* Unicode normalization routines?
* Allow for non-fixnum indexes?
* Documentation.
* Address the various XXX and TODO items in the source.
* Should we start adding a lot of encodings, a load-on-demand scheme
might come in handy. It would also help with debugging.
* Make the test suite reusable, very much like mappings are reusable.
* Make the whole thing easier to debug.

19
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/README.md Normal file
View file

@ -0,0 +1,19 @@
[![Build Status](https://travis-ci.org/cl-babel/babel.svg?branch=master)](https://travis-ci.org/cl-babel/babel)
Babel is a charset encoding/decoding library, not unlike GNU libiconv,
but completely written in Common Lisp.
It strives to achieve decent performance. To that effect, we use
OpenMCL's approach of calculating the destination buffer size in
advance. Most of the encoding/decoding algorithms have been adapted
from OpenMCL's source.
Another important goal is reusability. Similarly to SBCL, we define
an interface wherein the algorithms can be reused between a variety of
data types so long we're dealing with conversions between octets and
unicode code points.
Babel comes with converters between strings and (unsigned-byte 8)
vectors but can be easily extended to deal with, e.g., strings and
foreign memory, vectors and Closure's runes, etc...

38
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/babel-streams.asd Normal file
View file

@ -0,0 +1,38 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; babel-streams.asd --- ASDF system definition for Babel streams.
;;;
;;; Copyright (C) 2008, Attila Lendvai <attila.lendvai@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(defsystem :babel-streams
:description "Some useful streams based on Babel's encoding code"
:author ("Dr. Edmund Weitz"
"Attila Lendvai <attila.lendvai@gmail.com>")
:version "0.1.0"
:licence "MIT"
:depends-on (:babel :alexandria :trivial-gray-streams)
:components
((:module "src"
:serial t
:components
((:file "streams")))))

42
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/babel-tests.asd Normal file
View file

@ -0,0 +1,42 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; babel-tests.asd --- ASDF system definition for Babel unit tests.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(defsystem babel-tests
:description "Unit tests for Babel."
:depends-on (babel hu.dwim.stefil)
:components
((:module "tests"
:serial t
:components
((:file "tests")))))
(defmethod perform ((o test-op) (c (eql (find-system :babel-tests))))
(funcall (intern (string '#:run) '#:babel-tests)))
(defmethod operation-done-p ((o test-op) (c (eql (find-system :babel-tests))))
nil)
;;; vim: ft=lisp et

59
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/babel.asd Normal file
View file

@ -0,0 +1,59 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; babel.asd --- ASDF system definition for Babel.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(defsystem babel
:description "Babel, a charset conversion library."
:author "Luis Oliveira <loliveira@common-lisp.net>"
:licence "MIT"
:depends-on (trivial-features alexandria)
:components
((:module src
:serial t
:components
((:file "packages")
(:file "encodings")
(:file "enc-ascii")
(:file "enc-ebcdic")
(:file "enc-ebcdic-int")
(:file "enc-iso-8859")
(:file "enc-unicode")
(:file "enc-cp1251")
(:file "enc-cp1252")
(:file "jpn-table")
(:file "enc-jpn")
(:file "enc-gbk")
(:file "enc-koi8")
(:file "external-format")
(:file "strings")
(:file "gbk-map")
(:file "sharp-backslash")))))
(defmethod perform ((o test-op) (c (eql (find-system :babel))))
(operate 'load-op :babel-tests)
(operate 'test-op :babel-tests))
(defmethod operation-done-p ((o test-op) (c (eql (find-system :babel))))
nil)

31
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/doc/Makefile Normal file
View file

@ -0,0 +1,31 @@
# -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*-
MANUAL := "babel"
SYSTEM := "babel"
PACKAGES := babel babel-encodings
TITLE := "Babel Manual"
CSS := "default"
export LISP ?= sbcl
export SBCL_OPTIONS ?= --noinform
.PHONY: all clean html pdf upload
all:
texinfo-docstrings all $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES)
pdf:
texinfo-docstrings pdf $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES)
html:
texinfo-docstrings html $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES)
upload:
# rsync -av --delete -e ssh manual common-lisp.net:/project/FOO/public_html/
# scp -r manual common-lisp.net:/project/cffi/public_html/
clean:
find . \( -name "*.pdf" -o -name "*.html" -o -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \;
rm -rf include manual
# vim: ft=make ts=4 noet

105
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/doc/babel.texinfo Normal file
View file

@ -0,0 +1,105 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename babel.info
@settitle Babel Manual
@c @exampleindent 2
@c @documentencoding utf-8
@c %**end of header
@c for install-info
@c @dircategory %%INFO-CATEGORY%%
@c @direntry
@c * babel: %%PROJECT-DESCRIPTION%%
@c @end direntry
@include macros.texinfo
@c Show types, functions, and concepts in the same index.
@syncodeindex tp cp
@syncodeindex fn cp
@copying
@c Copyright @copyright{} 2084 John Doe <john@doe.com>
@include license.texinfo
@end copying
@titlepage
@title Babel Manual
@subtitle draft version
@c @author John Doe
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ifnottex
@node Top
@top babel
@insertcopying
@end ifnottex
@c Top Menu
@menu
* First Chapter::
* Comprehensive Index::
@end menu
@node First Chapter
@chapter First Chapter
Bla bla bla, bla bla bla.
@section Conditions
@include include/condition-babel-character-out-of-range.texinfo
@include include/condition-babel-encodings-character-out-of-range.texinfo
@include include/condition-babel-encodings-end-of-input-in-character.texinfo
@include include/condition-babel-encodings-invalid-utf8-continuation-byte.texinfo
@include include/condition-babel-encodings-invalid-utf8-starter-byte.texinfo
@include include/condition-babel-encodings-overlong-utf8-sequence.texinfo
@include include/condition-babel-end-of-input-in-character.texinfo
@include include/condition-babel-invalid-utf8-continuation-byte.texinfo
@include include/condition-babel-invalid-utf8-starter-byte.texinfo
@include include/condition-babel-overlong-utf8-sequence.texinfo
@include include/constant-babel-unicode-char-code-limit.texinfo
@section More stuff
@include include/fun-babel-encodings-get-character-encoding.texinfo
@include include/fun-babel-encodings-list-character-encodings.texinfo
@include include/fun-babel-encodings-lookup-mapping.texinfo
@include include/fun-babel-list-character-encodings.texinfo
@include include/macro-babel-encodings-with-checked-simple-vector.texinfo
@include include/macro-babel-encodings-with-simple-vector.texinfo
@include include/type-babel-simple-unicode-string.texinfo
@include include/type-babel-unicode-char.texinfo
@include include/type-babel-unicode-string.texinfo
@include include/var-babel-encodings-star-default-character-encoding-star.texinfo
@include include/var-babel-encodings-star-suppress-character-coding-errors-star.texinfo
@include include/var-babel-star-default-character-encoding-star.texinfo
@include include/var-babel-star-default-eol-style-star.texinfo
@c @include include/fun-somepackage-somefunction.texinfo
@c @include include/macro-somepackage-somemacro.texinfo
@c @node First Section
@c @section First Section
@c @include include/fun-somepackage-somefunction.texinfo
@c @include include/fun-somepackage-somefunction.texinfo
@c We call this node ``Comprehensive Index'' so that texinfo's HTML
@c output doesn't generate an index.html that'd overwrite the manual's
@c initial page.
@node Comprehensive Index
@unnumbered Index
@printindex cp
@bye

20
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/doc/license.texinfo Normal file
View file

@ -0,0 +1,20 @@
@quotation
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
``Software''), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
@sc{The software is provided ``as is'', without warranty of any kind,
express or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and noninfringement.
In no event shall the authors or copyright holders be liable for any
claim, damages or other liability, whether in an action of contract,
tort or otherwise, arising from, out of or in connection with the
software or the use or other dealings in the software.}
@end quotation

27
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/doc/macros.texinfo Normal file
View file

@ -0,0 +1,27 @@
@c Some plain TeX macrology to wrap text in \hbox{} only if the text
@c contains no hyphens.
@iftex
@tex
\newif\ifdash
\long\def\dashp#1{\expandafter\setnext#1-\dashphelper}
\long\def\setnext#1-{\futurelet\next\dashphelper}
\long\def\dashphelper#1\dashphelper{
\ifx\dashphelper\next\dashfalse\else\dashtrue\fi
}
\def\lw#1{\leavevmode\dashp{#1}\ifdash#1\else\hbox{#1}\fi}
@end tex
@end iftex
@c A Texinfo binding for the plain TeX above. Analogous to Texinfo's
@c @w, but for Lisp symbols. AFAICT, the comment characters are
@c necessary to prevent treating the newline as a space.
@macro lw{word}
@iftex
@tex
\\lw{\word\}%
@end tex
@end iftex
@ifnottex
\word\@c
@end ifnottex
@end macro

250
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/scripts/release.lisp Normal file
View file

@ -0,0 +1,250 @@
#!/usr/bin/env clisp
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
(defpackage :release-script (:use #:cl #:regexp))
(in-package :release-script)
;;;; Configuration ------------------------------------------------------------
(defparameter *project-name* "babel")
(defparameter *asdf-file* (format nil "~A.asd" *project-name*))
(defparameter *host* "common-lisp.net")
(defparameter *release-dir*
(format nil "/project/~A/public_html/releases" *project-name*))
(defparameter *version-file* "VERSION")
(defparameter *version-file-dir*
(format nil "/project/~A/public_html" *project-name*))
;;;; --------------------------------------------------------------------------
;;;; Utilities
(defun ensure-list (x)
(if (listp x) x (list x)))
(defmacro string-case (expression &body clauses)
`(let ((it ,expression)) ; yes, anaphoric, deal with it.
(cond
,@(loop for clause in clauses collect
`((or ,@(loop for alternative in (ensure-list (first clause))
collect (or (eq t alternative)
`(string= it ,alternative))))
,@(rest clause))))))
(defparameter *development-mode* nil)
(defun die (format-control &rest format-args)
(format *error-output* "~?" format-control format-args)
(if *development-mode*
(cerror "continue" "die")
(ext:quit 1)))
(defun numeric-split (string)
(if (digit-char-p (char string 0))
(multiple-value-bind (number next-position)
(parse-integer string :junk-allowed t)
(cons number (when (< next-position (length string))
(numeric-split (subseq string next-position)))))
(let ((next-digit-position (position-if #'digit-char-p string)))
(if next-digit-position
(cons (subseq string 0 next-digit-position)
(numeric-split (subseq string next-digit-position)))
(list string)))))
(defun natural-string-< (s1 s2)
(labels ((aux< (l1 l2)
(cond ((null l1) (not (null l2)))
((null l2) nil)
(t (destructuring-bind (x . xs) l1
(destructuring-bind (y . ys) l2
(cond ((and (numberp x) (stringp y))
t)
((and (numberp y) (stringp x))
nil)
((and (numberp x) (numberp y))
(or (< x y) (and (= x y) (aux< xs ys))))
(t
(or (string-lessp x y)
(and (string-equal x y)
(aux< xs ys)))))))))))
(aux< (numeric-split s1)
(numeric-split s2))))
;;;; Running commands
(defparameter *dry-run* nil)
(defun cmd? (format-control &rest format-args)
(let ((cmd (format nil "~?" format-control format-args)))
(with-open-stream (s1 (ext:run-shell-command cmd :output :stream))
(loop for line = (read-line s1 nil nil)
while line
collect line))))
;; XXX: quote arguments.
(defun cmd (format-control &rest format-args)
(when *development-mode*
(format *debug-io* "CMD: ~?~%" format-control format-args))
(let ((ret (ext:run-shell-command (format nil "~?" format-control format-args))))
(or (null ret)
(zerop ret))))
(defun cmd! (format-control &rest format-args)
(or (apply #'cmd format-control format-args)
(die "cmd '~?' failed." format-control format-args)))
(defun maybe-cmd! (format-control &rest format-args)
(if *dry-run*
(format t "SUPPRESSING: ~?~%" format-control format-args)
(apply #'cmd! format-control format-args)))
;;;;
(defun find-current-version ()
(subseq (reduce (lambda (x y) (if (natural-string-< x y) y x))
(or (cmd? "git tag -l v\\*")
(die "no version tags found. Please specify initial version.")))
1))
(defun parse-version (string)
(mapcar (lambda (x)
(parse-integer x :junk-allowed t))
(loop repeat 3 ; XXX: parameterize
for el in (regexp-split "\\." (find-current-version))
collect el)))
(defun check-for-unrecorded-changes (&optional force)
(unless (cmd "git diff --exit-code")
(write-line "Unrecorded changes.")
(if force
(write-line "Continuing anyway.")
(die "Aborting.~@
Use -f or --force if you want to make a release anyway."))))
(defun new-version-number-candidates (current-version)
(let ((current-version (parse-version current-version)))
(labels ((alternatives (before after)
(when after
(cons (append before (list (1+ (first after)))
(mapcar (constantly 0) (rest after)))
(alternatives (append before (list (first after)))
(rest after))))))
(loop for alt in (alternatives nil current-version)
collect (reduce (lambda (acc next)
(format nil "~a.~a" acc next))
alt)))))
(defun ask-user-for-version (current-version next-versions)
(format *query-io* "Current version is ~A. Which will be the next one?~%"
current-version)
(loop for i from 1 and version in next-versions
do (format *query-io* "~T~A) ~A~%" i version))
(format *query-io* "? ")
(finish-output *query-io*)
(nth (1- (parse-integer (read-line) :junk-allowed t))
next-versions))
(defun git-tag-tree (version)
(write-line "Tagging the tree...")
(maybe-cmd! "git tag \"v~A\"" version))
(defun add-version-to-system-file (version path-in path-out)
(with-open-file (in path-in :direction :input)
(with-open-file (out path-out :direction :output)
(loop for line = (read-line in nil nil) while line
do (write-line line out)
when (string= #1="(defsystem " line
:end2 (min (length #1#) (length line)))
do (format out " :version ~s~%" version)))))
(defun create-dist (version distname)
(write-line "Creating distribution...")
(cmd! "mkdir \"~a\"" distname)
(cmd! "git archive master | tar xC \"~A\"" distname)
(format t "Updating ~A with new version: ~A~%" *asdf-file* version)
(let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*))
(tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path)))
(add-version-to-system-file version asdf-file-path tmp-asdf-file-path)
(cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path)))
(defun tar-and-sign (distname tarball)
(write-line "Creating and signing tarball...")
(cmd! "tar czf \"~a\" \"~a\"" tarball distname)
(cmd! "gpg -b -a \"~a\"" tarball))
(defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*))
(defun upload-tarball (tarball signature remote-directory)
(write-line "Copying tarball to web server...")
(maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory)
(format t "Uploaded ~A and ~A.~%" tarball signature))
(defun update-remote-links (tarball signature host release-dir project-name)
(format t "Updating ~A_latest links...~%" project-name)
(maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\""
host tarball release-dir project-name)
(maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\""
host signature release-dir project-name))
(defun upload-version-file (version version-file host version-file-dir)
(format t "Uploading ~A...~%" version-file)
(with-open-file (out version-file :direction :output)
(write-string version out))
(maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir)
(maybe-cmd! "rm \"~A\"" version-file))
(defun maybe-clean-things-up (tarball signature)
(when (y-or-n-p "Clean local tarball and signature?")
(cmd! "rm \"~A\" \"~A\"" tarball signature)))
(defun run (force version)
(check-for-unrecorded-changes force)
;; figure out what version we'll be preparing.
(unless version
(let* ((current-version (find-current-version))
(next-versions (new-version-number-candidates current-version)))
(setf version (or (ask-user-for-version current-version next-versions)
(die "invalid selection.")))))
(git-tag-tree version)
(let* ((distname (format nil "~A_~A" *project-name* version))
(tarball (format nil "~A.tar.gz" distname))
(signature (format nil "~A.asc" tarball)))
;; package things up.
(create-dist version distname)
(tar-and-sign distname tarball)
;; upload.
(upload-tarball tarball signature *remote-directory*)
(update-remote-links tarball signature *host* *release-dir* *project-name*)
(when *version-file*
(upload-version-file version *version-file* *host* *version-file-dir*))
;; clean up.
(maybe-clean-things-up tarball signature)
;; documentation.
;; (write-line "Building and uploading documentation...")
;; (maybe-cmd! "make -C doc upload-docs")
;; push tags and any outstanding changes.
(write-line "Pushing tags and changes...")
(maybe-cmd! "git push --tags origin master")))
;;;; Do it to it
(let ((force nil)
(version nil)
(args ext:*args*))
(loop while args
do (string-case (pop args)
(("-h" "--help")
(write-line "No help, sorry. Read the source.")
(ext:quit 0))
(("-f" "--force")
(setf force t))
(("-v" "--version")
(setf version (pop args)))
(("-n" "--dry-run")
(setf *dry-run* t))
(t
(die "Unrecognized argument '~a'" it))))
(run force version))

43
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ascii.lisp Normal file
View file

@ -0,0 +1,43 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-ascii.lisp --- Implementation of the ASCII character encoding.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :ascii
"A 7-bit, fixed-width character encoding in which all
character codes map to their Unicode equivalents."
:aliases '(:us-ascii)
:literal-char-code-limit 128)
(define-unibyte-encoder :ascii (code)
(if (>= code 128)
(handle-error)
code))
(define-unibyte-decoder :ascii (octet)
(if (>= octet 128)
(handle-error)
octet))

119
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-cp1251.lisp Normal file
View file

@ -0,0 +1,119 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1251.lisp --- Implementation of the CP1251 character encoding.
;;;
;;; Copyright (C) 2009, Andrey Moskvitin
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :cp1251
"An 8-bit, fixed-width character Russian encoding from Windows."
:aliases '(:windows-1251)
:literal-char-code-limit #x80)
(define-constant +cp1251-to-unicode+
#(;; #x80
#x0402 #x0403 #x201a #x0453 #x201e #x2026 #x2020 #x2021
#x20ac #x2030 #x0409 #x2039 #x040a #x040c #x040b #x040f
;; #x90
#x0452 #x2018 #x2019 #x201c #x201d #x2022 #x2013 #x2014
#xfffd #x2122 #x0459 #x203a #x045a #x045c #x045b #x045f
;; #xa0
#x00a0 #x040e #x045e #x0408 #x00a4 #x0490 #x00a6 #x00a7
#x0401 #x00a9 #x0404 #x00ab #x00ac #x00ad #x00ae #x0407
;; #xb0
#x00b0 #x00b1 #x0406 #x0456 #x0491 #x00b5 #x00b6 #x00b7
#x0451 #x2116 #x0454 #x00bb #x0458 #x0405 #x0455 #x0457
;; #xc0
#x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
#x0418 #x0419 #x041a #x041b #x041c #x041d #x041e #x041f
;; #xd0
#x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
#x0428 #x0429 #x042a #x042b #x042c #x042d #x042e #x042f
;; #xe0
#x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
#x0438 #x0439 #x043a #x043b #x043c #x043d #x043e #x043f
;; #xf0
#x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
#x0448 #x0449 #x044a #x044b #x044c #x044d #x044e #x044f)
:test #'equalp)
(define-unibyte-decoder :cp1251 (octet)
(if (< octet #x80)
octet
(svref +cp1251-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-a0-bf-to-cp1251+
#(#xa0 #x00 #x00 #x00 #xa4 #x00 #xa6 #xa7 ; #xa0-#xa7
#x00 #xa9 #x00 #xab #xac #xad #xae #x00 ; #xa8-#xaf
#xb0 #xb1 #x00 #x00 #x00 #xb5 #xb6 #xb7 ; #xb0-#xb7
#x00 #x00 #x00 #xbb #x00 #x00 #x00 #x00) ; #xb8-#xbf
:test #'equalp)
(define-constant +unicode-0-97-to-cp1251+
#(#x00 #xa8 #x80 #x81 #xaa #xbd #xb2 #xaf ; #x00-#x07
#xa3 #x8a #x8c #x8e #x8d #x00 #xa1 #x8f ; #x08-#x0f
#xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x10-#x17
#xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x18-#x1f
#xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x20-#x27
#xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x28-#x2f
#xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x30-#x37
#xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x38-#x3f
#xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x40-#x47
#xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff ; #x48-#x4f
#x00 #xb8 #x90 #x83 #xba #xbe #xb3 #xbf ; #x50-#x57
#xbc #x9a #x9c #x9e #x9d #x00 #xa2 #x9f ; #x58-#x5f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x60-#x67
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x68-#x6f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x70-#x77
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x78-#x7f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x80-#x87
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x88-#x8f
#xa5 #xb4 #x00 #x00 #x00 #x00 #x00 #x00) ; #x90-#x97
:test #'equalp)
(define-constant +unicode-10-3f-to-cp1251+
#(#x00 #x00 #x00 #x96 #x97 #x00 #x00 #x00 ; #x10-#x17
#x91 #x92 #x82 #x00 #x93 #x94 #x84 #x00 ; #x18-#x1f
#x86 #x87 #x95 #x00 #x00 #x00 #x85 #x00 ; #x20-#x27
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x28-#x2f
#x89 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x30-#x37
#x00 #x8b #x9b #x00 #x00 #x00 #x00 #x00) ; #x38-#x3f
:test #'equalp)
(define-unibyte-encoder :cp1251 (code)
(cond
((< code #x80) code)
((and (>= code #xa0) (< code #xc0))
(svref +unicode-a0-bf-to-cp1251+
(the ub8 (- code #xa0))))
((and (>= code #x400) (< code #x498))
(svref +unicode-0-97-to-cp1251+
(the ub8 (- code #x400))))
((and (>= code #x2010) (< code #x2040))
(svref +unicode-10-3f-to-cp1251+
(the ub8 (- code #x2010))))
((= code #x20ac) #x88)
((= code #x2116) #xb9)
((= code #x2122) #x99)
(t (handle-error))))

81
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-cp1252.lisp Normal file
View file

@ -0,0 +1,81 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1252.lisp --- Implementation of the CP1252 character encoding.
;;;
;;; Copyright (C) 2011, Nicolas Martyanoff
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :cp1252
"A 8-bit, fixed-width character encoding used by Windows for Western
European languages."
:aliases '(:windows-1252)
:literal-char-code-limit 256)
(define-constant +cp1252-to-unicode+
#(#x20ac nil #x201a #x0192 #x201e #x2026 #x2020 #x2021
#x02c6 #x2030 #x0160 #x2039 #x0152 nil #x017d nil
nil #x2018 #x2019 #x201c #x201d #x2022 #x2013 #x2014
#x02dc #x2122 #x0161 #x203a #x0153 nil #x017e #x0178)
:test #'equalp)
(define-unibyte-decoder :cp1252 (octet)
(if (and (>= octet #x80) (<= octet #x9f))
(svref +cp1252-to-unicode+
(the ub8 (- octet #x80)))
octet))
(define-constant +unicode-0152-017e-cp1252+
#(#x8c #x9c #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x8a #x9a
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x9f #x00
#x00 #x00 #x00 #x8e #x9e)
:test #'equalp)
(define-constant +unicode-2013-203a-cp1252+
#(#x96 #x97 #x00 #x00 #x00 #x91 #x92 #x82
#x00 #x93 #x94 #x84 #x00 #x86 #x87 #x95
#x00 #x00 #x00 #x85 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x89 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x8b #x9b)
:test #'equalp)
(define-unibyte-encoder :cp1252 (code)
(cond
((or (< code #x80)
(and (> code #xa0) (<= code #xff)))
code)
((and (>= code #x0152) (<= code #x017e))
(svref +unicode-0152-017e-cp1252+
(the ub8 (- code #x0152))))
((= code #x0192) #x83)
((= code #x02c6) #x88)
((= code #x02dc) #x89)
((and (>= code #x2013) (<= code #x203a))
(svref +unicode-2013-203a-cp1252+
(the ub8 (- code #x2013))))
((= code #x20ac) #x80)
((= code #x2122) #x99)
(t (handle-error))))

49
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ebcdic-int.lisp Normal file
View file

@ -0,0 +1,49 @@
(in-package #:babel-encodings)
(define-character-encoding :ebcdic-international
"An 8-bit, fixed-width character encoding from IBM.")
(defparameter +ebcdic-int-to-unicode+
#(0 1 2 3 156 9 134 127 151 141 142 11 12 13 14 15 16 17 18 19 157 133 8 135
24 25 146 143 28 29 30 31 128 129 130 65535 132 10 23 27 65535 65535 138 139
65535 5 6 7 65535 65535 22 65535 148 149 150 4 65535 65535 65535 155 20 21
65535 26 32 65535 65535 65535 65535 65535 65535 65535 65535 65535 91 46 60
40 43 33 38 65535 65535 65535 65535 65535 65535 65535 65535 65535 93 164 42
41 59 172 45 47 65535 65535 65535 65535 65535 65535 65535 65535 124 44 37 95
62 63 65535 65535 65535 65535 65535 65535 1102 1072 1073 96 58 35 64 39 61
34 1094 97 98 99 100 101 102 103 104 105 1076 1077 1092 1075 1093 1080 1081
106 107 108 109 110 111 112 113 114 1082 1083 1084 1085 1086 1087 1103 126
115 116 117 118 119 120 121 122 1088 1089 1090 1091 1078 1074 1100 1099 1079
1096 1101 1097 1095 1098 1070 1040 1041 1062 1044 1045 1060 1043 123 65 66
67 68 69 70 71 72 73 1061 1048 1049 1050 1051 1052 125 74 75 76 77 78 79 80
81 82 1053 1054 1055 1071 1056 1057 92 65535 83 84 85 86 87 88 89 90 1058
1059 1046 1042 1068 1067 48 49 50 51 52 53 54 55 56 57 1047 1064 1069 1065
1063 159))
(defparameter +unicode-upto-ac-ebcdic-int+
#(0 1 2 3 55 45 46 47 22 5 37 11 12 13 14 15 16 17 18 19 60 61 50 38 24 25 63
39 28 29 30 31 64 79 127 123 0 108 80 125 77 93 92 78 107 96 75 97 240 241
242 243 244 245 246 247 248 249 122 94 76 126 110 111 124 193 194 195 196
197 198 199 200 201 209 210 211 212 213 214 215 216 217 226 227 228 229 230
231 232 233 74 224 90 0 109 121 129 130 131 132 133 134 135 136 137 145 146
147 148 149 150 151 152 153 162 163 164 165 166 167 168 169 192 106 208 161
7 32 33 34 0 36 21 6 23 0 0 42 43 0 9 10 27 0 0 26 0 52 53 54 8 0 0 0 59 4
20 0 255 0 0 0 0 91 0 0 0 0 0 0 0 95))
(defparameter +unicode-0410-0450-ebcdic-int+
#(185 186 237 191 188 189 236 250 203 204 205 206 207 218 219 220 222 223 234
235 190 202 187 254 251 253 0 239 238 252 184 221 119 120 175 141 138 139
174 178 143 144 154 155 156 157 158 159 170 171 172 173 140 142 128 182 179
181 183 177 176 180 118 160))
(define-unibyte-decoder :ebcdic-international (octet)
(svref +ebcdic-int-to-unicode+ (the ub8 octet)))
(define-unibyte-encoder :ebcdic-international (code)
(let ((result (cond
((<= code 172) (svref +unicode-upto-ac-ebcdic-int+ code))
((<= #x0410 code #x0450) (svref +unicode-0410-0450-ebcdic-int+
(- code #x0410))))))
(prog1 result
(when (and (zerop result) (plusp code))
(handle-error)))))

71
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ebcdic.lisp Normal file
View file

@ -0,0 +1,71 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-ebcdic.lisp --- EBCDIC encodings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :ebcdic-us
"An alleged character set used on IBM dinosaurs."
:aliases '(:ibm-037))
(define-constant +ebcdic-decode-table+
(make-array
256 :element-type 'ub8 :initial-contents
'(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d
#x0e #x0f #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f
#x1c #x1d #x1e #x1f #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89
#x8a #x8b #x8c #x05 #x06 #x07 #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04
#x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a #x20 #xa0 #xe2 #xe4 #xe0 #xe1
#xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c #x26 #xe9 #xea #xeb
#xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac #x2d #x2f
#xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
#xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27
#x3d #x22 #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb
#xf0 #xfd #xfe #xb1 #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72
#xaa #xba #xe6 #xb8 #xc6 #xa4 #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78
#x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae #x5e #xa3 #xa5 #xb7 #xa9 #xa7
#xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 #x7b #x41 #x42 #x43
#x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 #x7d #x4a
#x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
#x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2
#xd3 #xd5 #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb
#xdc #xd9 #xda #x9f))
:test #'equalp)
(define-constant +ebcdic-encode-table+
(loop with rt = (make-array 256 :element-type 'ub8 :initial-element 0)
for code across +ebcdic-decode-table+ for i from 0 do
(assert (= 0 (aref rt code)))
(setf (aref rt code) i)
finally (return rt))
:test #'equalp)
(define-unibyte-encoder :ebcdic-us (code)
(if (>= code 256)
(handle-error)
(aref +ebcdic-encode-table+ code)))
(define-unibyte-decoder :ebcdic-us (octet)
(aref +ebcdic-decode-table+ octet))

184
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-gbk.lisp Normal file
View file

@ -0,0 +1,184 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-gbk.lisp --- GBK encodings.
;;;
;;; Copyright (C) 2011, Li Wenpeng <levin108@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
;; populated in gbk-map.lisp
(defvar *gbk-unicode-mapping*)
(defconstant +gbk2-offset+ 0)
(defconstant +gbk3-offset+ 6763)
(defconstant +gbk4-offset+ (+ 6763 6080))
(defconstant +gbk1-offset+ 20902)
(defconstant +gbk5-offset+ (+ 20902 846))
(define-character-encoding :gbk
"GBK is an extension of the GB2312 character set for simplified
Chinese characters, used in the People's Republic of China."
:max-units-per-char 4
:literal-char-code-limit #x80)
(define-condition invalid-gbk-byte (character-decoding-error)
()
(:documentation "Signalled when an invalid GBK byte is found."))
(define-condition invalid-gbk-character (character-encoding-error)
()
(:documentation "Signalled when an invalid GBK character is found."))
(define-octet-counter :gbk (getter type)
`(lambda (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(let ((noctets 0))
(loop for i from start below end
for u1 of-type code-point = (,getter seq i)
do (cond ((< u1 #x80) (incf noctets))
(t (incf noctets 2)))
(when (and (plusp max) (= noctets max))
(return (values noctets i)))
finally (return (values noctets i))))))
(define-code-point-counter :gbk (getter type)
`(lambda (seq start end max)
(declare (type ,type seq))
(let (u1 (noctets 0))
(loop with i = start
while (< i end)
do (setf u1 (,getter seq i))
(cond
((eq 0 (logand u1 #x80)) (incf i))
(t (incf i 2)))
(incf noctets)
(when (and (plusp max) (= noctets max))
(return (values noctets i)))
finally (return (values noctets i))))))
(define-encoder :gbk (getter src-type setter dest-type)
`(lambda (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(macrolet
((do-encoding (index)
`(let ((u1 0) (u2 0))
(cond
((<= +gbk2-offset+ ,index (- +gbk3-offset+ 1)) ; gbk/2
(setf u1 (+ #xB0 (truncate (/ ,index 94))))
(setf u2 (+ #xA1 (mod ,index 94))))
((<= +gbk3-offset+ ,index (- +gbk4-offset+ 1)) ; gbk/3
(setf index (- ,index +gbk3-offset+))
(setf u1 (+ #x81 (truncate (/ ,index 190))))
(setf u2 (+ #x40 (mod ,index 190)))
(if (>= u2 #x7F) (incf u2)))
((<= +gbk4-offset+ ,index (- +gbk1-offset+ 1)) ; gbk/4
(setf index (- ,index +gbk4-offset+))
(setf u1 (+ #xAA (truncate (/ ,index 96))))
(setf u2 (+ #x40 (mod ,index 96)))
(if (>= u2 #x7F) (incf u2)))
((<= +gbk1-offset+ ,index (- +gbk5-offset+ 1)) ; gbk/1
(setf index (- ,index +gbk1-offset+))
(setf u1 (+ #xA1 (truncate (/ ,index 94))))
(setf u2 (+ #xA1 (mod ,index 94))))
((<= +gbk5-offset+ ,index (length *gbk-unicode-mapping*)) ; gbk/5
(setf index (- ,index +gbk5-offset+))
(setf u1 (+ #xA8 (truncate (/ ,index 96))))
(setf u2 (+ #x40 (mod ,index 96)))
(if (>= u2 #x7F) (incf u2))))
(values u1 u2))))
(let ((c 0) index (noctets 0))
(loop for i from start below end
for code of-type code-point = (,getter src i)
do (macrolet
((handle-error (&optional (c 'character-encoding-error))
`(encoding-error code :gbk src i +repl+ ',c)))
(setf c (code-char code))
(cond
((< code #x80) ; ascii
(,setter code dest noctets)
(incf noctets))
(t ; gbk
(setf index
(position c *gbk-unicode-mapping*))
(if (not index)
(handle-error invalid-gbk-character))
(multiple-value-bind (uh ul) (do-encoding index)
(,setter uh dest noctets)
(,setter ul dest (+ 1 noctets))
(incf noctets 2)))))
finally (return (the fixnum (- noctets d-start))))))))
(define-decoder :gbk (getter src-type setter dest-type)
`(lambda (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest))
(let ((u1 0) (u2 0) (index 0) (tmp 0) (noctets 0))
(loop with i = start
while (< i end)
do (macrolet
((handle-error (&optional (c 'character-decoding-error))
`(decoding-error #(u1 u2) :gbk src i +repl+ ',c)))
(setf u1 (,getter src i))
(incf i)
(cond
((eq 0 (logand u1 #x80))
(,setter u1 dest noctets))
(t
(setf u2 (,getter src i))
(incf i)
(setf index
(block setter-block
(cond
((and (<= #xB0 u1 #xF7) (<= #xA1 u2 #xFE))
(+ +gbk2-offset+ (+ (* 94 (- u1 #xB0)) (- u2 #xA1))))
((and (<= #x81 u1 #xA0) (<= #x40 u2 #xFE))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk3-offset+ (* 190 (- u1 #x81)) (- u2 #x40 tmp)))
((and (<= #xAA u1 #xFE) (<= #x40 #xA0))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk4-offset+ (* 96 (- u1 #xAA)) (- u2 #x40 tmp)))
((and (<= #xA1 u1 #xA9) (<= #xA1 u2 #xFE))
(+ +gbk1-offset+ (* 94 (- u1 #xA1)) (- u2 #xA1)))
((and (<= #xA8 u1 #xA9) (<= #x40 #xA0))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk5-offset+ (* 96 (- u1 #xA8)) (- u2 #x40 tmp)))
(t
(handle-error invalid-gbk-byte)))))
(when (>= index (length *gbk-unicode-mapping*))
(handle-error invalid-gbk-byte))
(,setter (char-code
(elt *gbk-unicode-mapping* index))
dest noctets)))
(incf noctets))
finally (return (the fixnum (- noctets d-start)))))))

1087
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-iso-8859.lisp Normal file
View file

File diff suppressed because it is too large Load diff

767
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-jpn.lisp Normal file
View file

@ -0,0 +1,767 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-jpn.lisp --- Japanese encodings.
;;;
(in-package #:babel-encodings)
;;;; helper functions
(defvar *eucjp-to-ucs-hash* (make-hash-table))
(defvar *ucs-to-eucjp-hash* (make-hash-table))
(defvar *cp932-to-ucs-hash* (make-hash-table))
(defvar *ucs-to-cp932-hash* (make-hash-table))
(dolist (i `((,*cp932-only*
,*cp932-to-ucs-hash*
,*ucs-to-cp932-hash*)
(,*eucjp-only*
,*eucjp-to-ucs-hash*
,*ucs-to-eucjp-hash*)
(,*eucjp*
,*eucjp-to-ucs-hash*
,*ucs-to-eucjp-hash*)))
(dolist (j (first i))
(setf (gethash (car j) (second i)) (cadr j))
(setf (gethash (cadr j) (third i)) (car j))))
(flet ((euc-cp932 (x)
(let ((high (ash x -16))
(mid (logand (ash x -8) 255))
(low (logand x 255)))
(cond ((not (zerop high))
nil)
((= mid #x8e)
(logand x 255))
((zerop mid)
x)
((decf mid #xa1)
(decf low #x80)
(incf low (if (zerop (logand mid 1)) #x1f #x7e))
(incf low (if (<= #x7f low #x9d) 1 0))
(setq mid (ash mid -1))
(incf mid (if (<= mid #x1e) #x81 #xc1))
(+ (ash mid 8) low))))))
(dolist (i *eucjp*)
(let ((cp932 (euc-cp932 (first i))))
(when cp932
(setf (gethash cp932 *cp932-to-ucs-hash*) (second i))
(setf (gethash (second i) *ucs-to-cp932-hash*) cp932)))))
;ascii
(loop for i from #x00 to #x7f do
(setf (gethash i *cp932-to-ucs-hash*) i)
(setf (gethash i *eucjp-to-ucs-hash*) i)
(setf (gethash i *ucs-to-eucjp-hash*) i)
(setf (gethash i *ucs-to-cp932-hash*) i))
;half-width katakana
(loop for i from #xa1 to #xdf do
(setf (gethash i *cp932-to-ucs-hash*) (+ #xff61 #x-a1 i))
(setf (gethash (+ #xff61 #x-a1 i) *ucs-to-cp932-hash*) i)
(setf (gethash (+ #x8e00 i) *eucjp-to-ucs-hash*) (+ #xff61 #x-a1 i))
(setf (gethash (+ #xff61 #x-a1 i) *ucs-to-eucjp-hash*) (+ #x8e00 i)))
;; This is quoted from https://support.microsoft.com/en-us/kb/170559/en-us
(let ((kb170559 "0x8790 -> U+2252 -> 0x81e0 Approximately Equal To Or The Image Of
0x8791 -> U+2261 -> 0x81df Identical To
0x8792 -> U+222b -> 0x81e7 Integral
0x8795 -> U+221a -> 0x81e3 Square Root
0x8796 -> U+22a5 -> 0x81db Up Tack
0x8797 -> U+2220 -> 0x81da Angle
0x879a -> U+2235 -> 0x81e6 Because
0x879b -> U+2229 -> 0x81bf Intersection
0x879c -> U+222a -> 0x81be Union
0xed40 -> U+7e8a -> 0xfa5c CJK Unified Ideograph
0xed41 -> U+891c -> 0xfa5d CJK Unified Ideograph
0xed42 -> U+9348 -> 0xfa5e CJK Unified Ideograph
0xed43 -> U+9288 -> 0xfa5f CJK Unified Ideograph
0xed44 -> U+84dc -> 0xfa60 CJK Unified Ideograph
0xed45 -> U+4fc9 -> 0xfa61 CJK Unified Ideograph
0xed46 -> U+70bb -> 0xfa62 CJK Unified Ideograph
0xed47 -> U+6631 -> 0xfa63 CJK Unified Ideograph
0xed48 -> U+68c8 -> 0xfa64 CJK Unified Ideograph
0xed49 -> U+92f9 -> 0xfa65 CJK Unified Ideograph
0xed4a -> U+66fb -> 0xfa66 CJK Unified Ideograph
0xed4b -> U+5f45 -> 0xfa67 CJK Unified Ideograph
0xed4c -> U+4e28 -> 0xfa68 CJK Unified Ideograph
0xed4d -> U+4ee1 -> 0xfa69 CJK Unified Ideograph
0xed4e -> U+4efc -> 0xfa6a CJK Unified Ideograph
0xed4f -> U+4f00 -> 0xfa6b CJK Unified Ideograph
0xed50 -> U+4f03 -> 0xfa6c CJK Unified Ideograph
0xed51 -> U+4f39 -> 0xfa6d CJK Unified Ideograph
0xed52 -> U+4f56 -> 0xfa6e CJK Unified Ideograph
0xed53 -> U+4f92 -> 0xfa6f CJK Unified Ideograph
0xed54 -> U+4f8a -> 0xfa70 CJK Unified Ideograph
0xed55 -> U+4f9a -> 0xfa71 CJK Unified Ideograph
0xed56 -> U+4f94 -> 0xfa72 CJK Unified Ideograph
0xed57 -> U+4fcd -> 0xfa73 CJK Unified Ideograph
0xed58 -> U+5040 -> 0xfa74 CJK Unified Ideograph
0xed59 -> U+5022 -> 0xfa75 CJK Unified Ideograph
0xed5a -> U+4fff -> 0xfa76 CJK Unified Ideograph
0xed5b -> U+501e -> 0xfa77 CJK Unified Ideograph
0xed5c -> U+5046 -> 0xfa78 CJK Unified Ideograph
0xed5d -> U+5070 -> 0xfa79 CJK Unified Ideograph
0xed5e -> U+5042 -> 0xfa7a CJK Unified Ideograph
0xed5f -> U+5094 -> 0xfa7b CJK Unified Ideograph
0xed60 -> U+50f4 -> 0xfa7c CJK Unified Ideograph
0xed61 -> U+50d8 -> 0xfa7d CJK Unified Ideograph
0xed62 -> U+514a -> 0xfa7e CJK Unified Ideograph
0xed63 -> U+5164 -> 0xfa80 CJK Unified Ideograph
0xed64 -> U+519d -> 0xfa81 CJK Unified Ideograph
0xed65 -> U+51be -> 0xfa82 CJK Unified Ideograph
0xed66 -> U+51ec -> 0xfa83 CJK Unified Ideograph
0xed67 -> U+5215 -> 0xfa84 CJK Unified Ideograph
0xed68 -> U+529c -> 0xfa85 CJK Unified Ideograph
0xed69 -> U+52a6 -> 0xfa86 CJK Unified Ideograph
0xed6a -> U+52c0 -> 0xfa87 CJK Unified Ideograph
0xed6b -> U+52db -> 0xfa88 CJK Unified Ideograph
0xed6c -> U+5300 -> 0xfa89 CJK Unified Ideograph
0xed6d -> U+5307 -> 0xfa8a CJK Unified Ideograph
0xed6e -> U+5324 -> 0xfa8b CJK Unified Ideograph
0xed6f -> U+5372 -> 0xfa8c CJK Unified Ideograph
0xed70 -> U+5393 -> 0xfa8d CJK Unified Ideograph
0xed71 -> U+53b2 -> 0xfa8e CJK Unified Ideograph
0xed72 -> U+53dd -> 0xfa8f CJK Unified Ideograph
0xed73 -> U+fa0e -> 0xfa90 CJK compatibility Ideograph
0xed74 -> U+549c -> 0xfa91 CJK Unified Ideograph
0xed75 -> U+548a -> 0xfa92 CJK Unified Ideograph
0xed76 -> U+54a9 -> 0xfa93 CJK Unified Ideograph
0xed77 -> U+54ff -> 0xfa94 CJK Unified Ideograph
0xed78 -> U+5586 -> 0xfa95 CJK Unified Ideograph
0xed79 -> U+5759 -> 0xfa96 CJK Unified Ideograph
0xed7a -> U+5765 -> 0xfa97 CJK Unified Ideograph
0xed7b -> U+57ac -> 0xfa98 CJK Unified Ideograph
0xed7c -> U+57c8 -> 0xfa99 CJK Unified Ideograph
0xed7d -> U+57c7 -> 0xfa9a CJK Unified Ideograph
0xed7e -> U+fa0f -> 0xfa9b CJK compatibility Ideograph
0xed80 -> U+fa10 -> 0xfa9c CJK compatibility Ideograph
0xed81 -> U+589e -> 0xfa9d CJK Unified Ideograph
0xed82 -> U+58b2 -> 0xfa9e CJK Unified Ideograph
0xed83 -> U+590b -> 0xfa9f CJK Unified Ideograph
0xed84 -> U+5953 -> 0xfaa0 CJK Unified Ideograph
0xed85 -> U+595b -> 0xfaa1 CJK Unified Ideograph
0xed86 -> U+595d -> 0xfaa2 CJK Unified Ideograph
0xed87 -> U+5963 -> 0xfaa3 CJK Unified Ideograph
0xed88 -> U+59a4 -> 0xfaa4 CJK Unified Ideograph
0xed89 -> U+59ba -> 0xfaa5 CJK Unified Ideograph
0xed8a -> U+5b56 -> 0xfaa6 CJK Unified Ideograph
0xed8b -> U+5bc0 -> 0xfaa7 CJK Unified Ideograph
0xed8c -> U+752f -> 0xfaa8 CJK Unified Ideograph
0xed8d -> U+5bd8 -> 0xfaa9 CJK Unified Ideograph
0xed8e -> U+5bec -> 0xfaaa CJK Unified Ideograph
0xed8f -> U+5c1e -> 0xfaab CJK Unified Ideograph
0xed90 -> U+5ca6 -> 0xfaac CJK Unified Ideograph
0xed91 -> U+5cba -> 0xfaad CJK Unified Ideograph
0xed92 -> U+5cf5 -> 0xfaae CJK Unified Ideograph
0xed93 -> U+5d27 -> 0xfaaf CJK Unified Ideograph
0xed94 -> U+5d53 -> 0xfab0 CJK Unified Ideograph
0xed95 -> U+fa11 -> 0xfab1 CJK compatibility Ideograph
0xed96 -> U+5d42 -> 0xfab2 CJK Unified Ideograph
0xed97 -> U+5d6d -> 0xfab3 CJK Unified Ideograph
0xed98 -> U+5db8 -> 0xfab4 CJK Unified Ideograph
0xed99 -> U+5db9 -> 0xfab5 CJK Unified Ideograph
0xed9a -> U+5dd0 -> 0xfab6 CJK Unified Ideograph
0xed9b -> U+5f21 -> 0xfab7 CJK Unified Ideograph
0xed9c -> U+5f34 -> 0xfab8 CJK Unified Ideograph
0xed9d -> U+5f67 -> 0xfab9 CJK Unified Ideograph
0xed9e -> U+5fb7 -> 0xfaba CJK Unified Ideograph
0xed9f -> U+5fde -> 0xfabb CJK Unified Ideograph
0xeda0 -> U+605d -> 0xfabc CJK Unified Ideograph
0xeda1 -> U+6085 -> 0xfabd CJK Unified Ideograph
0xeda2 -> U+608a -> 0xfabe CJK Unified Ideograph
0xeda3 -> U+60de -> 0xfabf CJK Unified Ideograph
0xeda4 -> U+60d5 -> 0xfac0 CJK Unified Ideograph
0xeda5 -> U+6120 -> 0xfac1 CJK Unified Ideograph
0xeda6 -> U+60f2 -> 0xfac2 CJK Unified Ideograph
0xeda7 -> U+6111 -> 0xfac3 CJK Unified Ideograph
0xeda8 -> U+6137 -> 0xfac4 CJK Unified Ideograph
0xeda9 -> U+6130 -> 0xfac5 CJK Unified Ideograph
0xedaa -> U+6198 -> 0xfac6 CJK Unified Ideograph
0xedab -> U+6213 -> 0xfac7 CJK Unified Ideograph
0xedac -> U+62a6 -> 0xfac8 CJK Unified Ideograph
0xedad -> U+63f5 -> 0xfac9 CJK Unified Ideograph
0xedae -> U+6460 -> 0xfaca CJK Unified Ideograph
0xedaf -> U+649d -> 0xfacb CJK Unified Ideograph
0xedb0 -> U+64ce -> 0xfacc CJK Unified Ideograph
0xedb1 -> U+654e -> 0xfacd CJK Unified Ideograph
0xedb2 -> U+6600 -> 0xface CJK Unified Ideograph
0xedb3 -> U+6615 -> 0xfacf CJK Unified Ideograph
0xedb4 -> U+663b -> 0xfad0 CJK Unified Ideograph
0xedb5 -> U+6609 -> 0xfad1 CJK Unified Ideograph
0xedb6 -> U+662e -> 0xfad2 CJK Unified Ideograph
0xedb7 -> U+661e -> 0xfad3 CJK Unified Ideograph
0xedb8 -> U+6624 -> 0xfad4 CJK Unified Ideograph
0xedb9 -> U+6665 -> 0xfad5 CJK Unified Ideograph
0xedba -> U+6657 -> 0xfad6 CJK Unified Ideograph
0xedbb -> U+6659 -> 0xfad7 CJK Unified Ideograph
0xedbc -> U+fa12 -> 0xfad8 CJK compatibility Ideograph
0xedbd -> U+6673 -> 0xfad9 CJK Unified Ideograph
0xedbe -> U+6699 -> 0xfada CJK Unified Ideograph
0xedbf -> U+66a0 -> 0xfadb CJK Unified Ideograph
0xedc0 -> U+66b2 -> 0xfadc CJK Unified Ideograph
0xedc1 -> U+66bf -> 0xfadd CJK Unified Ideograph
0xedc2 -> U+66fa -> 0xfade CJK Unified Ideograph
0xedc3 -> U+670e -> 0xfadf CJK Unified Ideograph
0xedc4 -> U+f929 -> 0xfae0 CJK compatibility Ideograph
0xedc5 -> U+6766 -> 0xfae1 CJK Unified Ideograph
0xedc6 -> U+67bb -> 0xfae2 CJK Unified Ideograph
0xedc7 -> U+6852 -> 0xfae3 CJK Unified Ideograph
0xedc8 -> U+67c0 -> 0xfae4 CJK Unified Ideograph
0xedc9 -> U+6801 -> 0xfae5 CJK Unified Ideograph
0xedca -> U+6844 -> 0xfae6 CJK Unified Ideograph
0xedcb -> U+68cf -> 0xfae7 CJK Unified Ideograph
0xedcc -> U+fa13 -> 0xfae8 CJK compatibility Ideograph
0xedcd -> U+6968 -> 0xfae9 CJK Unified Ideograph
0xedce -> U+fa14 -> 0xfaea CJK compatibility Ideograph
0xedcf -> U+6998 -> 0xfaeb CJK Unified Ideograph
0xedd0 -> U+69e2 -> 0xfaec CJK Unified Ideograph
0xedd1 -> U+6a30 -> 0xfaed CJK Unified Ideograph
0xedd2 -> U+6a6b -> 0xfaee CJK Unified Ideograph
0xedd3 -> U+6a46 -> 0xfaef CJK Unified Ideograph
0xedd4 -> U+6a73 -> 0xfaf0 CJK Unified Ideograph
0xedd5 -> U+6a7e -> 0xfaf1 CJK Unified Ideograph
0xedd6 -> U+6ae2 -> 0xfaf2 CJK Unified Ideograph
0xedd7 -> U+6ae4 -> 0xfaf3 CJK Unified Ideograph
0xedd8 -> U+6bd6 -> 0xfaf4 CJK Unified Ideograph
0xedd9 -> U+6c3f -> 0xfaf5 CJK Unified Ideograph
0xedda -> U+6c5c -> 0xfaf6 CJK Unified Ideograph
0xeddb -> U+6c86 -> 0xfaf7 CJK Unified Ideograph
0xeddc -> U+6c6f -> 0xfaf8 CJK Unified Ideograph
0xeddd -> U+6cda -> 0xfaf9 CJK Unified Ideograph
0xedde -> U+6d04 -> 0xfafa CJK Unified Ideograph
0xeddf -> U+6d87 -> 0xfafb CJK Unified Ideograph
0xede0 -> U+6d6f -> 0xfafc CJK Unified Ideograph
0xede1 -> U+6d96 -> 0xfb40 CJK Unified Ideograph
0xede2 -> U+6dac -> 0xfb41 CJK Unified Ideograph
0xede3 -> U+6dcf -> 0xfb42 CJK Unified Ideograph
0xede4 -> U+6df8 -> 0xfb43 CJK Unified Ideograph
0xede5 -> U+6df2 -> 0xfb44 CJK Unified Ideograph
0xede6 -> U+6dfc -> 0xfb45 CJK Unified Ideograph
0xede7 -> U+6e39 -> 0xfb46 CJK Unified Ideograph
0xede8 -> U+6e5c -> 0xfb47 CJK Unified Ideograph
0xede9 -> U+6e27 -> 0xfb48 CJK Unified Ideograph
0xedea -> U+6e3c -> 0xfb49 CJK Unified Ideograph
0xedeb -> U+6ebf -> 0xfb4a CJK Unified Ideograph
0xedec -> U+6f88 -> 0xfb4b CJK Unified Ideograph
0xeded -> U+6fb5 -> 0xfb4c CJK Unified Ideograph
0xedee -> U+6ff5 -> 0xfb4d CJK Unified Ideograph
0xedef -> U+7005 -> 0xfb4e CJK Unified Ideograph
0xedf0 -> U+7007 -> 0xfb4f CJK Unified Ideograph
0xedf1 -> U+7028 -> 0xfb50 CJK Unified Ideograph
0xedf2 -> U+7085 -> 0xfb51 CJK Unified Ideograph
0xedf3 -> U+70ab -> 0xfb52 CJK Unified Ideograph
0xedf4 -> U+710f -> 0xfb53 CJK Unified Ideograph
0xedf5 -> U+7104 -> 0xfb54 CJK Unified Ideograph
0xedf6 -> U+715c -> 0xfb55 CJK Unified Ideograph
0xedf7 -> U+7146 -> 0xfb56 CJK Unified Ideograph
0xedf8 -> U+7147 -> 0xfb57 CJK Unified Ideograph
0xedf9 -> U+fa15 -> 0xfb58 CJK compatibility Ideograph
0xedfa -> U+71c1 -> 0xfb59 CJK Unified Ideograph
0xedfb -> U+71fe -> 0xfb5a CJK Unified Ideograph
0xedfc -> U+72b1 -> 0xfb5b CJK Unified Ideograph
0xee40 -> U+72be -> 0xfb5c CJK Unified Ideograph
0xee41 -> U+7324 -> 0xfb5d CJK Unified Ideograph
0xee42 -> U+fa16 -> 0xfb5e CJK compatibility Ideograph
0xee43 -> U+7377 -> 0xfb5f CJK Unified Ideograph
0xee44 -> U+73bd -> 0xfb60 CJK Unified Ideograph
0xee45 -> U+73c9 -> 0xfb61 CJK Unified Ideograph
0xee46 -> U+73d6 -> 0xfb62 CJK Unified Ideograph
0xee47 -> U+73e3 -> 0xfb63 CJK Unified Ideograph
0xee48 -> U+73d2 -> 0xfb64 CJK Unified Ideograph
0xee49 -> U+7407 -> 0xfb65 CJK Unified Ideograph
0xee4a -> U+73f5 -> 0xfb66 CJK Unified Ideograph
0xee4b -> U+7426 -> 0xfb67 CJK Unified Ideograph
0xee4c -> U+742a -> 0xfb68 CJK Unified Ideograph
0xee4d -> U+7429 -> 0xfb69 CJK Unified Ideograph
0xee4e -> U+742e -> 0xfb6a CJK Unified Ideograph
0xee4f -> U+7462 -> 0xfb6b CJK Unified Ideograph
0xee50 -> U+7489 -> 0xfb6c CJK Unified Ideograph
0xee51 -> U+749f -> 0xfb6d CJK Unified Ideograph
0xee52 -> U+7501 -> 0xfb6e CJK Unified Ideograph
0xee53 -> U+756f -> 0xfb6f CJK Unified Ideograph
0xee54 -> U+7682 -> 0xfb70 CJK Unified Ideograph
0xee55 -> U+769c -> 0xfb71 CJK Unified Ideograph
0xee56 -> U+769e -> 0xfb72 CJK Unified Ideograph
0xee57 -> U+769b -> 0xfb73 CJK Unified Ideograph
0xee58 -> U+76a6 -> 0xfb74 CJK Unified Ideograph
0xee59 -> U+fa17 -> 0xfb75 CJK compatibility Ideograph
0xee5a -> U+7746 -> 0xfb76 CJK Unified Ideograph
0xee5b -> U+52af -> 0xfb77 CJK Unified Ideograph
0xee5c -> U+7821 -> 0xfb78 CJK Unified Ideograph
0xee5d -> U+784e -> 0xfb79 CJK Unified Ideograph
0xee5e -> U+7864 -> 0xfb7a CJK Unified Ideograph
0xee5f -> U+787a -> 0xfb7b CJK Unified Ideograph
0xee60 -> U+7930 -> 0xfb7c CJK Unified Ideograph
0xee61 -> U+fa18 -> 0xfb7d CJK compatibility Ideograph
0xee62 -> U+fa19 -> 0xfb7e CJK compatibility Ideograph
0xee63 -> U+fa1a -> 0xfb80 CJK compatibility Ideograph
0xee64 -> U+7994 -> 0xfb81 CJK Unified Ideograph
0xee65 -> U+fa1b -> 0xfb82 CJK compatibility Ideograph
0xee66 -> U+799b -> 0xfb83 CJK Unified Ideograph
0xee67 -> U+7ad1 -> 0xfb84 CJK Unified Ideograph
0xee68 -> U+7ae7 -> 0xfb85 CJK Unified Ideograph
0xee69 -> U+fa1c -> 0xfb86 CJK compatibility Ideograph
0xee6a -> U+7aeb -> 0xfb87 CJK Unified Ideograph
0xee6b -> U+7b9e -> 0xfb88 CJK Unified Ideograph
0xee6c -> U+fa1d -> 0xfb89 CJK compatibility Ideograph
0xee6d -> U+7d48 -> 0xfb8a CJK Unified Ideograph
0xee6e -> U+7d5c -> 0xfb8b CJK Unified Ideograph
0xee6f -> U+7db7 -> 0xfb8c CJK Unified Ideograph
0xee70 -> U+7da0 -> 0xfb8d CJK Unified Ideograph
0xee71 -> U+7dd6 -> 0xfb8e CJK Unified Ideograph
0xee72 -> U+7e52 -> 0xfb8f CJK Unified Ideograph
0xee73 -> U+7f47 -> 0xfb90 CJK Unified Ideograph
0xee74 -> U+7fa1 -> 0xfb91 CJK Unified Ideograph
0xee75 -> U+fa1e -> 0xfb92 CJK compatibility Ideograph
0xee76 -> U+8301 -> 0xfb93 CJK Unified Ideograph
0xee77 -> U+8362 -> 0xfb94 CJK Unified Ideograph
0xee78 -> U+837f -> 0xfb95 CJK Unified Ideograph
0xee79 -> U+83c7 -> 0xfb96 CJK Unified Ideograph
0xee7a -> U+83f6 -> 0xfb97 CJK Unified Ideograph
0xee7b -> U+8448 -> 0xfb98 CJK Unified Ideograph
0xee7c -> U+84b4 -> 0xfb99 CJK Unified Ideograph
0xee7d -> U+8553 -> 0xfb9a CJK Unified Ideograph
0xee7e -> U+8559 -> 0xfb9b CJK Unified Ideograph
0xee80 -> U+856b -> 0xfb9c CJK Unified Ideograph
0xee81 -> U+fa1f -> 0xfb9d CJK compatibility Ideograph
0xee82 -> U+85b0 -> 0xfb9e CJK Unified Ideograph
0xee83 -> U+fa20 -> 0xfb9f CJK compatibility Ideograph
0xee84 -> U+fa21 -> 0xfba0 CJK compatibility Ideograph
0xee85 -> U+8807 -> 0xfba1 CJK Unified Ideograph
0xee86 -> U+88f5 -> 0xfba2 CJK Unified Ideograph
0xee87 -> U+8a12 -> 0xfba3 CJK Unified Ideograph
0xee88 -> U+8a37 -> 0xfba4 CJK Unified Ideograph
0xee89 -> U+8a79 -> 0xfba5 CJK Unified Ideograph
0xee8a -> U+8aa7 -> 0xfba6 CJK Unified Ideograph
0xee8b -> U+8abe -> 0xfba7 CJK Unified Ideograph
0xee8c -> U+8adf -> 0xfba8 CJK Unified Ideograph
0xee8d -> U+fa22 -> 0xfba9 CJK compatibility Ideograph
0xee8e -> U+8af6 -> 0xfbaa CJK Unified Ideograph
0xee8f -> U+8b53 -> 0xfbab CJK Unified Ideograph
0xee90 -> U+8b7f -> 0xfbac CJK Unified Ideograph
0xee91 -> U+8cf0 -> 0xfbad CJK Unified Ideograph
0xee92 -> U+8cf4 -> 0xfbae CJK Unified Ideograph
0xee93 -> U+8d12 -> 0xfbaf CJK Unified Ideograph
0xee94 -> U+8d76 -> 0xfbb0 CJK Unified Ideograph
0xee95 -> U+fa23 -> 0xfbb1 CJK compatibility Ideograph
0xee96 -> U+8ecf -> 0xfbb2 CJK Unified Ideograph
0xee97 -> U+fa24 -> 0xfbb3 CJK compatibility Ideograph
0xee98 -> U+fa25 -> 0xfbb4 CJK compatibility Ideograph
0xee99 -> U+9067 -> 0xfbb5 CJK Unified Ideograph
0xee9a -> U+90de -> 0xfbb6 CJK Unified Ideograph
0xee9b -> U+fa26 -> 0xfbb7 CJK compatibility Ideograph
0xee9c -> U+9115 -> 0xfbb8 CJK Unified Ideograph
0xee9d -> U+9127 -> 0xfbb9 CJK Unified Ideograph
0xee9e -> U+91da -> 0xfbba CJK Unified Ideograph
0xee9f -> U+91d7 -> 0xfbbb CJK Unified Ideograph
0xeea0 -> U+91de -> 0xfbbc CJK Unified Ideograph
0xeea1 -> U+91ed -> 0xfbbd CJK Unified Ideograph
0xeea2 -> U+91ee -> 0xfbbe CJK Unified Ideograph
0xeea3 -> U+91e4 -> 0xfbbf CJK Unified Ideograph
0xeea4 -> U+91e5 -> 0xfbc0 CJK Unified Ideograph
0xeea5 -> U+9206 -> 0xfbc1 CJK Unified Ideograph
0xeea6 -> U+9210 -> 0xfbc2 CJK Unified Ideograph
0xeea7 -> U+920a -> 0xfbc3 CJK Unified Ideograph
0xeea8 -> U+923a -> 0xfbc4 CJK Unified Ideograph
0xeea9 -> U+9240 -> 0xfbc5 CJK Unified Ideograph
0xeeaa -> U+923c -> 0xfbc6 CJK Unified Ideograph
0xeeab -> U+924e -> 0xfbc7 CJK Unified Ideograph
0xeeac -> U+9259 -> 0xfbc8 CJK Unified Ideograph
0xeead -> U+9251 -> 0xfbc9 CJK Unified Ideograph
0xeeae -> U+9239 -> 0xfbca CJK Unified Ideograph
0xeeaf -> U+9267 -> 0xfbcb CJK Unified Ideograph
0xeeb0 -> U+92a7 -> 0xfbcc CJK Unified Ideograph
0xeeb1 -> U+9277 -> 0xfbcd CJK Unified Ideograph
0xeeb2 -> U+9278 -> 0xfbce CJK Unified Ideograph
0xeeb3 -> U+92e7 -> 0xfbcf CJK Unified Ideograph
0xeeb4 -> U+92d7 -> 0xfbd0 CJK Unified Ideograph
0xeeb5 -> U+92d9 -> 0xfbd1 CJK Unified Ideograph
0xeeb6 -> U+92d0 -> 0xfbd2 CJK Unified Ideograph
0xeeb7 -> U+fa27 -> 0xfbd3 CJK compatibility Ideograph
0xeeb8 -> U+92d5 -> 0xfbd4 CJK Unified Ideograph
0xeeb9 -> U+92e0 -> 0xfbd5 CJK Unified Ideograph
0xeeba -> U+92d3 -> 0xfbd6 CJK Unified Ideograph
0xeebb -> U+9325 -> 0xfbd7 CJK Unified Ideograph
0xeebc -> U+9321 -> 0xfbd8 CJK Unified Ideograph
0xeebd -> U+92fb -> 0xfbd9 CJK Unified Ideograph
0xeebe -> U+fa28 -> 0xfbda CJK compatibility Ideograph
0xeebf -> U+931e -> 0xfbdb CJK Unified Ideograph
0xeec0 -> U+92ff -> 0xfbdc CJK Unified Ideograph
0xeec1 -> U+931d -> 0xfbdd CJK Unified Ideograph
0xeec2 -> U+9302 -> 0xfbde CJK Unified Ideograph
0xeec3 -> U+9370 -> 0xfbdf CJK Unified Ideograph
0xeec4 -> U+9357 -> 0xfbe0 CJK Unified Ideograph
0xeec5 -> U+93a4 -> 0xfbe1 CJK Unified Ideograph
0xeec6 -> U+93c6 -> 0xfbe2 CJK Unified Ideograph
0xeec7 -> U+93de -> 0xfbe3 CJK Unified Ideograph
0xeec8 -> U+93f8 -> 0xfbe4 CJK Unified Ideograph
0xeec9 -> U+9431 -> 0xfbe5 CJK Unified Ideograph
0xeeca -> U+9445 -> 0xfbe6 CJK Unified Ideograph
0xeecb -> U+9448 -> 0xfbe7 CJK Unified Ideograph
0xeecc -> U+9592 -> 0xfbe8 CJK Unified Ideograph
0xeecd -> U+f9dc -> 0xfbe9 CJK compatibility Ideograph
0xeece -> U+fa29 -> 0xfbea CJK compatibility Ideograph
0xeecf -> U+969d -> 0xfbeb CJK Unified Ideograph
0xeed0 -> U+96af -> 0xfbec CJK Unified Ideograph
0xeed1 -> U+9733 -> 0xfbed CJK Unified Ideograph
0xeed2 -> U+973b -> 0xfbee CJK Unified Ideograph
0xeed3 -> U+9743 -> 0xfbef CJK Unified Ideograph
0xeed4 -> U+974d -> 0xfbf0 CJK Unified Ideograph
0xeed5 -> U+974f -> 0xfbf1 CJK Unified Ideograph
0xeed6 -> U+9751 -> 0xfbf2 CJK Unified Ideograph
0xeed7 -> U+9755 -> 0xfbf3 CJK Unified Ideograph
0xeed8 -> U+9857 -> 0xfbf4 CJK Unified Ideograph
0xeed9 -> U+9865 -> 0xfbf5 CJK Unified Ideograph
0xeeda -> U+fa2a -> 0xfbf6 CJK compatibility Ideograph
0xeedb -> U+fa2b -> 0xfbf7 CJK compatibility Ideograph
0xeedc -> U+9927 -> 0xfbf8 CJK Unified Ideograph
0xeedd -> U+fa2c -> 0xfbf9 CJK compatibility Ideograph
0xeede -> U+999e -> 0xfbfa CJK Unified Ideograph
0xeedf -> U+9a4e -> 0xfbfb CJK Unified Ideograph
0xeee0 -> U+9ad9 -> 0xfbfc CJK Unified Ideograph
0xeee1 -> U+9adc -> 0xfc40 CJK Unified Ideograph
0xeee2 -> U+9b75 -> 0xfc41 CJK Unified Ideograph
0xeee3 -> U+9b72 -> 0xfc42 CJK Unified Ideograph
0xeee4 -> U+9b8f -> 0xfc43 CJK Unified Ideograph
0xeee5 -> U+9bb1 -> 0xfc44 CJK Unified Ideograph
0xeee6 -> U+9bbb -> 0xfc45 CJK Unified Ideograph
0xeee7 -> U+9c00 -> 0xfc46 CJK Unified Ideograph
0xeee8 -> U+9d70 -> 0xfc47 CJK Unified Ideograph
0xeee9 -> U+9d6b -> 0xfc48 CJK Unified Ideograph
0xeeea -> U+fa2d -> 0xfc49 CJK compatibility Ideograph
0xeeeb -> U+9e19 -> 0xfc4a CJK Unified Ideograph
0xeeec -> U+9ed1 -> 0xfc4b CJK Unified Ideograph
0xeeef -> U+2170 -> 0xfa40 Small Roman Numeral One
0xeef0 -> U+2171 -> 0xfa41 Small Roman Numeral Two
0xeef1 -> U+2172 -> 0xfa42 Small Roman Numeral Three
0xeef2 -> U+2173 -> 0xfa43 Small Roman Numeral Four
0xeef3 -> U+2174 -> 0xfa44 Small Roman Numeral Five
0xeef4 -> U+2175 -> 0xfa45 Small Roman Numeral Six
0xeef5 -> U+2176 -> 0xfa46 Small Roman Numeral Seven
0xeef6 -> U+2177 -> 0xfa47 Small Roman Numeral Eight
0xeef7 -> U+2178 -> 0xfa48 Small Roman Numeral Nine
0xeef8 -> U+2179 -> 0xfa49 Small Roman Numeral Ten
0xeef9 -> U+ffe2 -> 0x81ca Fullwidth Not Sign
0xeefa -> U+ffe4 -> 0xfa55 Fullwidth Broken Bar
0xeefb -> U+ff07 -> 0xfa56 Fullwidth Apostrophe
0xeefc -> U+ff02 -> 0xfa57 Fullwidth Quotation Mark
0xfa4a -> U+2160 -> 0x8754 Roman Numeral One
0xfa4b -> U+2161 -> 0x8755 Roman Numeral Two
0xfa4c -> U+2162 -> 0x8756 Roman Numeral Three
0xfa4d -> U+2163 -> 0x8757 Roman Numeral Four
0xfa4e -> U+2164 -> 0x8758 Roman Numeral Five
0xfa4f -> U+2165 -> 0x8759 Roman Numeral Six
0xfa50 -> U+2166 -> 0x875a Roman Numeral Seven
0xfa51 -> U+2167 -> 0x875b Roman Numeral Eight
0xfa52 -> U+2168 -> 0x875c Roman Numeral Nine
0xfa53 -> U+2169 -> 0x875d Roman Numeral Ten
0xfa54 -> U+ffe2 -> 0x81ca Fullwidth Not Sign
0xfa58 -> U+3231 -> 0x878a Parenthesized Ideograph Stock
0xfa59 -> U+2116 -> 0x8782 Numero Sign
0xfa5a -> U+2121 -> 0x8784 Telephone Sign
0xfa5b -> U+2235 -> 0x81e6 Because"))
(with-input-from-string (s kb170559)
(loop for line = (read-line s nil) until (null line)
do (let ((ucs (parse-integer (subseq line 14 18) :radix 16))
(cp932 (parse-integer (subseq line 26 30) :radix 16)))
(setf (gethash ucs *ucs-to-cp932-hash*) cp932)))))
(defun eucjp-to-ucs (code)
(values (gethash code *eucjp-to-ucs-hash*)))
(defun ucs-to-eucjp (code)
(values (gethash code *ucs-to-eucjp-hash*)))
(defun cp932-to-ucs (code)
(values (gethash code *cp932-to-ucs-hash*)))
(defun ucs-to-cp932 (code)
(values (gethash code *ucs-to-cp932-hash*)))
;;;; EUC-JP
(define-character-encoding :eucjp
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 3 bytes."
:max-units-per-char 3
:literal-char-code-limit #x80)
(define-octet-counter :eucjp (getter type)
`(named-lambda eucjp-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let* ((c (ucs-to-eucjp code))
(new (+ (cond ((< #xffff c) 3)
((< #xff c) 2)
(t 1))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :eucjp (getter type)
`(named-lambda eucjp-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((= #x8f octet) 3)
((or (< #xa0 octet #xff)
(= #x8e octet)) 2)
(t 1)))))
(declare (type ub8 octet) (fixnum next-i))
(cond ((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :eucjp seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i))))))
finally (progn (assert (= i end))
(return (values nchars i))))))
(define-encoder :eucjp (getter src-type setter dest-type)
`(named-lambda eucjp-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for eucjp of-type code-point
= (ucs-to-eucjp code) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< eucjp #x100)
(set-octet 0 eucjp)
(incf di))
;; 2 octets
((< eucjp #x10000)
(set-octet 0 (f-logand #xff (f-ash eucjp -8)))
(set-octet 1 (logand eucjp #xff))
(incf di 2))
;; 3 octets
(t
(set-octet 0 (f-logand #xff (f-ash eucjp -16)))
(set-octet 1 (f-logand #xff (f-ash eucjp -8)))
(set-octet 2 (logand eucjp #xff))
(incf di 3))
))
finally (return (the fixnum (- di d-start))))))
(define-decoder :eucjp (getter src-type setter dest-type)
`(named-lambda eucjp-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0))
(declare (type ub8 u2))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :eucjp src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2) 0 n))
:eucjp src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
;; 3 octets
((= u1 #x8f)
(setq u2 (consume-octet))
(eucjp-to-ucs (logior #x8f0000
(f-ash u2 8)
(consume-octet))))
;; 2 octets
((or (= u1 #x8e)
(< #xa0 u1 #xff))
(eucjp-to-ucs (logior (f-ash u1 8)
(consume-octet))))
;; 1 octet
(t
(eucjp-to-ucs u1))))
dest di))
finally (return (the fixnum (- di d-start)))))))
;;;; CP932
(define-character-encoding :cp932
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 bytes."
:max-units-per-char 2
:literal-char-code-limit #x80)
(define-octet-counter :cp932 (getter type)
`(named-lambda cp932-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let* ((c (ucs-to-cp932 code))
(new (+ (cond ((< #xff c) 2)
(t 1))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :cp932 (getter type)
`(named-lambda cp932-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((or (<= #x81 octet #x9f)
(<= #xe0 octet #xfc))
2)
(t 1)))))
(declare (type ub8 octet) (fixnum next-i))
(cond ((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :cp932 seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i))))))
finally (progn (assert (= i end))
(return (values nchars i))))))
(define-encoder :cp932 (getter src-type setter dest-type)
`(named-lambda cp932-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for cp932 of-type code-point
= (ucs-to-cp932 code) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< cp932 #x100)
(set-octet 0 cp932)
(incf di))
;; 2 octets
((< cp932 #x10000)
(set-octet 0 (f-logand #xff (f-ash cp932 -8)))
(set-octet 1 (logand cp932 #xff))
(incf di 2))
;; 3 octets
(t
(set-octet 0 (f-logand #xff (f-ash cp932 -16)))
(set-octet 1 (f-logand #xff (f-ash cp932 -8)))
(set-octet 2 (logand cp932 #xff))
(incf di 3))
))
finally (return (the fixnum (- di d-start))))))
(define-decoder :cp932 (getter src-type setter dest-type)
`(named-lambda cp932-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0))
(declare (type ub8 u2))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :cp932 src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2) 0 n))
:cp932 src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
;; 2 octets
((or (<= #x81 u1 #x9f)
(<= #xe0 u1 #xfc))
(setq u2 (consume-octet))
(cp932-to-ucs (logior (f-ash u1 8)
u2)))
;; 1 octet
(t
(cp932-to-ucs u1))))
dest di))
finally (return (the fixnum (- di d-start)))))))

577
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-koi8.lisp Normal file
View file

@ -0,0 +1,577 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1251.lisp --- Implementation of the CP1251 character encoding.
;;;
;;; Copyright (C) 2009, Andrey Moskvitin
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :koi8-ru
"An 8-bit, fixed-width character Russian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-ru-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x0454 #x2554 #x0456 #x0457
#x2557 #x2558 #x2559 #x255A #x255B #x0491 #x045E #x255E
#x255F #x2560 #x2561 #x0401 #x0404 #x2563 #x0406 #x0407
#x2566 #x2567 #x2568 #x2569 #x256A #x0490 #x040E #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
:test #'equalp)
(define-unibyte-decoder :koi8-ru (octet)
(if (< octet #x80)
octet
(svref +koi8-ru-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-04->koi8-ru+
#(#x7f #x79 #x78 #x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a
#x49 #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48
#x43 #x5e #x5b #x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23 nil nil #x24
nil #x26 #x27 nil nil nil nil nil nil #x2e nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil #x3d #x2d)
:test 'equalp)
(define-unibyte-encoder :koi8-ru (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x4 #xb4)
(#x6 #xb6)
(#x7 #xb7)
(#xe #xbe)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)
(#x54 #xa4)
(#x56 #xa6)
(#x57 #xa7)
(#x5e #xae)
(#x90 #xbd)
(#x91 #xad)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x54 #xa5)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x63 #xb5)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))
(define-character-encoding :koi8-r
"An 8-bit, fixed-width character Russian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-r-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
#x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
#x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
#x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
:test #'equalp)
(define-unibyte-decoder :koi8-r (octet)
(if (< octet #x80)
octet
(svref +koi8-r-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-x04->koi8-r+
#(nil #x33 nil nil nil nil nil nil nil nil nil nil nil nil nil nil #x61
#x62 #x77 #x67 #x64 #x65 #x76 #x7a #x69 #x6a #x6b #x6c #x6d #x6e #x6f
#x70 #x72 #x73 #x74 #x75 #x66 #x68 #x63 #x7e #x7b #x7d #x7f #x79 #x78
#x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a #x49 #x4a #x4b
#x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48 #x43 #x5e #x5b
#x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23)
:test 'equalp)
(define-constant +unicode-x25->koi8-r+
#(#x0 nil #x1 nil nil nil nil nil nil nil nil nil #x2 nil nil nil #x3 nil
nil nil #x4 nil nil nil #x5 nil nil nil #x6 nil nil nil nil nil nil nil
#x7 nil nil nil nil nil nil nil #x8 nil nil nil nil nil nil nil #x9 nil
nil nil nil nil nil nil #xa nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #x20 #x21 #x22 #x24 #x25 #x26 #x27 #x28
#x29 #x2a #x2b #x2c #x2d #x2e #x2f #x30 #x31 #x32 #x34 #x35 #x36 #x37
#x38 #x39 #x3a #x3b #x3c #x3d #x3e nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil #xb nil nil nil #xc nil nil nil
#xd nil nil nil #xe nil nil nil #xf #x10 #x11 #x12 nil nil nil nil nil
nil nil nil nil nil nil nil #x14)
:test 'equalp)
(define-unibyte-encoder :koi8-r (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x53 #xa4)
(#x54 #xa5)
(#x55 #xa6)
(#x56 #xa7)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5c #xad)
(#x5d #xae)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x62 #xb4)
(#x63 #xb5)
(#x64 #xb6)
(#x65 #xb7)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x6b #xbd)
(#x6c #xbe)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))
(define-character-encoding :koi8-u
"An 8-bit, fixed-width character Ukranian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-u-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x0454 #x2554 #x0456 #x0457
#x2557 #x2558 #x2559 #x255A #x255B #x0491 #x255D #x255E
#x255F #x2560 #x2561 #x0401 #x0404 #x2563 #x0406 #x0407
#x2566 #x2567 #x2568 #x2569 #x256A #x0490 #x256C #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A )
:test #'equalp)
(define-unibyte-decoder :koi8-u (octet)
(if (< octet #x80)
octet
(svref +koi8-u-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-x04->koi8-u+
#(nil #x33 nil nil #x34 nil #x36 #x37 nil nil nil nil nil nil nil nil #x61
#x62 #x77 #x67 #x64 #x65 #x76 #x7a #x69 #x6a #x6b #x6c #x6d #x6e #x6f
#x70 #x72 #x73 #x74 #x75 #x66 #x68 #x63 #x7e #x7b #x7d #x7f #x79 #x78
#x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a #x49 #x4a #x4b
#x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48 #x43 #x5e #x5b
#x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23 nil nil #x24 nil #x26 #x27
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil #x3d #x2d)
:test 'equalp)
(define-constant +unicode-x25->koi8-u+
#(#x0 nil #x1 nil nil nil nil nil nil nil nil nil #x2 nil nil nil #x3 nil
nil nil #x4 nil nil nil #x5 nil nil nil #x6 nil nil nil nil nil nil nil
#x7 nil nil nil nil nil nil nil #x8 nil nil nil nil nil nil nil #x9 nil
nil nil nil nil nil nil #xa nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #x20 #x21 #x22 nil #x25 nil nil #x28
#x29 #x2a #x2b #x2c nil #x2e #x2f #x30 #x31 #x32 nil #x35 nil nil #x38
#x39 #x3a #x3b #x3c nil #x3e nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #xb nil nil nil #xc nil nil nil #xd nil
nil nil #xe nil nil nil #xf #x10 #x11 #x12 nil nil nil nil nil nil nil
nil nil nil nil nil #x14)
:test 'equalp)
(define-unibyte-encoder :koi8-u (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x4 #xb4)
(#x6 #xb6)
(#x7 #xb7)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)
(#x54 #xa4)
(#x56 #xa6)
(#x57 #xa7)
(#x90 #xbd)
(#x91 #xad)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x54 #xa5)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5d #xae)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x63 #xb5)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x6c #xbe)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))

881
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-unicode.lisp Normal file
View file

@ -0,0 +1,881 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-unicode.lisp --- Unicode encodings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; This implementation is largely based on OpenMCL's l1-unicode.lisp
;;; Copyright (C) 2006 Clozure Associates and contributors.
(in-package #:babel-encodings)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +repl+ #xfffd "Unicode replacement character code point.")
(defconstant +byte-order-mark-code+ #xfeff)
(defconstant +swapped-byte-order-mark-code+ #xfffe)
(defconstant +swapped-byte-order-mark-code-32+ #xfffe0000))
;;; Some convenience macros adding FIXNUM declarations.
(defmacro f-ash (integer count) `(the fixnum (ash ,integer ,count)))
(defmacro f-logior (&rest integers) `(the fixnum (logior ,@integers)))
(defmacro f-logand (&rest integers) `(the fixnum (logand ,@integers)))
(defmacro f-logxor (&rest integers) `(the fixnum (logxor ,@integers)))
;;;; UTF-8
(define-character-encoding :utf-8
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes."
:max-units-per-char 4
:literal-char-code-limit #x80
:bom-encoding #(#xef #xbb #xbf)
:default-replacement #xfffd)
(define-condition invalid-utf8-starter-byte (character-decoding-error)
()
(:documentation "Signalled when an invalid UTF-8 starter byte is found."))
(define-condition invalid-utf8-continuation-byte (character-decoding-error)
()
(:documentation
"Signalled when an invalid UTF-8 continuation byte is found."))
(define-condition overlong-utf8-sequence (character-decoding-error)
()
(:documentation "Signalled upon overlong UTF-8 sequences."))
(define-octet-counter :utf-8 (getter type)
`(named-lambda utf-8-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i) do
(let ((new (+ (cond ((< code #x80) 1)
((< code #x800) 2)
((< code #x10000) 3)
(t 4))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :utf-8 (getter type)
`(named-lambda utf-8-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
;; check for invalid continuation bytes
(macrolet ((invalid-cb-p (n)
`(and (< (+ i ,n) end)
(not (< #x7f (,',getter seq (+ i ,n)) #xc0)))))
;; wrote this code with LET instead of FOR because CLISP's
;; LOOP doesn't like WHILE clauses before FOR clauses.
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((or (< octet #xc0) (invalid-cb-p 1)) 1)
((or (< octet #xe0) (invalid-cb-p 2)) 2)
((or (< octet #xf0) (invalid-cb-p 3)) 3)
((or (< octet #xf8) (invalid-cb-p 4)) 4)
((or (< octet #xfc) (invalid-cb-p 5)) 5)
(t 6)))))
(declare (type ub8 octet) (fixnum next-i))
(cond
((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :utf-8 seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i)))))))
finally (progn
(assert (= i end))
(return (values nchars i))))))
(define-encoder :utf-8 (getter src-type setter dest-type)
`(named-lambda utf-8-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< code #x80)
(set-octet 0 code)
(incf di))
;; 2 octets
((< code #x800)
(set-octet 0 (logior #xc0 (f-ash code -6)))
(set-octet 1 (logior #x80 (f-logand code #x3f)))
(incf di 2))
;; 3 octets
((< code #x10000)
(set-octet 0 (logior #xe0 (f-ash code -12)))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 2 (logior #x80 (f-logand code #x3f)))
(incf di 3))
;; 4 octets
(t
(set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
(set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 3 (logior #x80 (logand code #x3f)))
(incf di 4))))
finally (return (the fixnum (- di d-start))))))
(define-decoder :utf-8 (getter src-type setter dest-type)
`(named-lambda utf-8-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0) (u3 0) (u4 0) (u5 0) (u6 0))
(declare (type ub8 u2 u3 u4 u5 u6))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :utf-8 src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2 u3 u4 u5 u6) 0 n))
:utf-8 src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
((< u1 #x80) u1) ; 1 octet
((< u1 #xc0)
(handle-error 1 invalid-utf8-starter-byte))
(t
(setq u2 (consume-octet))
(handle-error-if-icb u2 1)
(cond
((< u1 #xc2)
(handle-error 2 overlong-utf8-sequence))
((< u1 #xe0) ; 2 octets
(logior (f-ash (f-logand #x1f u1) 6)
(f-logxor u2 #x80)))
(t
(setq u3 (consume-octet))
(handle-error-if-icb u3 2)
(cond
((and (= u1 #xe0) (< u2 #xa0))
(handle-error 3 overlong-utf8-sequence))
((< u1 #xf0) ; 3 octets
(let ((start (f-logior (f-ash (f-logand u1 #x0f) 12)
(f-ash (f-logand u2 #x3f) 6))))
(if (<= #xd800 start #xdfc0)
(handle-error 3 character-out-of-range)
(logior start (f-logand u3 #x3f)))))
(t ; 4 octets
(setq u4 (consume-octet))
(handle-error-if-icb u4 3)
(cond
((and (= u1 #xf0) (< u2 #x90))
(handle-error 4 overlong-utf8-sequence))
((< u1 #xf8)
(if (or (> u1 #xf4) (and (= u1 #xf4) (> u2 #x8f)))
(handle-error 4 character-out-of-range)
(f-logior (f-ash (f-logand u1 7) 18)
(f-ash (f-logxor u2 #x80) 12)
(f-ash (f-logxor u3 #x80) 6)
(f-logxor u4 #x80))))
;; from here on we'll be getting either
;; invalid continuation bytes or overlong
;; 5-byte or 6-byte sequences.
(t
(setq u5 (consume-octet))
(handle-error-if-icb u5 4)
(cond
((and (= u1 #xf8) (< u2 #x88))
(handle-error 5 overlong-utf8-sequence))
((< u1 #xfc)
(handle-error 5 character-out-of-range))
(t
(setq u6 (consume-octet))
(handle-error-if-icb u6 5)
(cond
((and (= u1 #xfc) (< u2 #x84))
(handle-error 6 overlong-utf8-sequence))
(t
(handle-error 6 character-out-of-range)
)))))))))))))
dest di))
finally (return (the fixnum (- di d-start)))))))
;;;; UTF-8B
;;; The following excerpt from a linux-utf8 message by Markus Kuhn is
;;; the closest thing to a UTF-8B specification:
;;;
;;; <http://mail.nl.linux.org/linux-utf8/2000-07/msg00040.html>
;;;
;;; "D) Emit a malformed UTF-16 sequence for every byte in a malformed
;;; UTF-8 sequence
;;;
;;; All the previous options for converting malformed UTF-8 sequences
;;; to UTF-16 destroy information. This can be highly undesirable in
;;; applications such as text file editors, where guaranteed binary
;;; transparency is a desireable feature. (E.g., I frequently edit
;;; executable code or graphic files with the Emacs text editor and I
;;; hate the idea that my editor might automatically make U+FFFD
;;; substitutions at locations that I haven't even edited when I save
;;; the file again.)
;;;
;;; I therefore suggested 1999-11-02 on the unicode@xxxxxxxxxxx
;;; mailing list the following approach. Instead of using U+FFFD,
;;; simply encode malformed UTF-8 sequences as malformed UTF-16
;;; sequences. Malformed UTF-8 sequences consist excludively of the
;;; bytes 0x80 - 0xff, and each of these bytes can be represented
;;; using a 16-bit value from the UTF-16 low-half surrogate zone
;;; U+DC80 to U+DCFF. Thus, the overlong "K" (U+004B) 0xc1 0x8b from
;;; the above example would be represented in UTF-16 as U+DCC1
;;; U+DC8B. If we simply make sure that every UTF-8 encoded surrogate
;;; character is also treated like a malformed sequence, then there
;;; is no way that a single high-half surrogate could precede the
;;; encoded malformed sequence and cause a valid UTF-16 sequence to
;;; emerge.
;;;
;;; This way 100% binary transparent UTF-8 -> UTF-16 -> UTF-8
;;; round-trip compatibility can be achieved quite easily.
;;;
;;; On an output device, a lonely low-half surrogate character should
;;; be treated just like a character outside the adopted subset of
;;; representable characters, that is for the end user, the display
;;; would look exactly like with semantics B), i.e. one symbol per
;;; byte of a malformed sequence. However in contrast to semantics
;;; B), no information is thrown away, and a cut&paste in an editor
;;; or terminal emulator will be guaranteed to reconstruct the
;;; original byte sequence. This should greatly reduce the incidence
;;; of accidental corruption of binary data by UTF-8 -> UTF-16 ->
;;; UTF-8 conversion round trips."
(define-character-encoding :utf-8b
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes. Invalid UTF-8 sequences are encoded with #xDCXX
code points for each invalid byte."
:max-units-per-char 4
:literal-char-code-limit #x80
:bom-encoding #(#xef #xbb #xbf)
:default-replacement nil)
;;; TODO: reuse the :UTF-8 octet counter through a simple macro.
(define-octet-counter :utf-8b (getter type)
`(named-lambda utf-8b-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i) do
(let ((new (+ (cond ((< code #x80) 1)
((< code #x800) 2)
((<= #xdc80 code #xdcff) 1)
((< code #x10000) 3)
(t 4))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :utf-8b (getter type)
`(named-lambda utf-8b-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
;; wrote this code with LET instead of FOR because CLISP's
;; LOOP doesn't like WHILE clauses before FOR clauses.
(let* ((octet (,getter seq i))
(noctets (cond ((< octet #x80) 1)
((< octet #xe0) 2)
((< octet #xf0) 3)
(t 4))))
(declare (type ub8 octet) (fixnum noctets))
(cond
((> (+ i noctets) end)
;; If this error is suppressed these last few bytes
;; will be encoded as raw bytes later.
(decoding-error (vector octet) :utf-8 seq i
nil 'end-of-input-in-character)
(return (values (+ nchars (- end i)) end)))
(t
;; FIXME: clean this mess up.
(let* ((u1 octet)
(u2 (if (>= noctets 2) (,getter seq (1+ i)) 0))
(u3 (if (>= noctets 3) (,getter seq (+ i 2)) 0))
(u4 (if (= noctets 4) (,getter seq (+ i 3)) 0))
(inc (or (and (> noctets 1)
(< u1 #xc2))
(and (= noctets 2)
(not (logior u2 #x40)))
(and (= noctets 3)
(not (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(or (>= u1 #xe1) (>= u2 #xa0))
(or (/= u1 #xed) (< u2 #xa0) (> u2 #xbf)))))
(and (= noctets 4)
(not
(and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(< (f-logxor u4 #x80) #x40)
(or (>= u1 #xf1) (>= u2 #x90))))))))
(let ((new-nchars (if inc (+ nchars noctets) (1+ nchars))))
(when (and (plusp max) (> new-nchars max))
(return (values nchars i)))
(incf i noctets)
(setq nchars new-nchars))))))
finally (progn
(assert (= i end))
(return (values nchars i))))))
;;; TODO: reuse the :UTF-8 encoder with through a simple macro.
(define-encoder :utf-8b (getter src-type setter dest-type)
`(named-lambda utf-8b-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< code #x80)
(set-octet 0 code)
(incf di))
;; 2 octets
((< code #x800)
(set-octet 0 (logior #xc0 (f-ash code -6)))
(set-octet 1 (logior #x80 (f-logand code #x3f)))
(incf di 2))
;; 1 octet (invalid octet)
((<= #xdc80 code #xdcff)
(set-octet 0 (f-logand code #xff))
(incf di))
;; 3 octets
((< code #x10000)
(set-octet 0 (logior #xe0 (f-ash code -12)))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 2 (logior #x80 (f-logand code #x3f)))
(incf di 3))
;; 4 octets
(t
(set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
(set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 3 (logand #x3f code))
(incf di 4))))
finally (return (the fixnum (- di d-start))))))
(define-decoder :utf-8b (getter src-type setter dest-type)
`(named-lambda utf-8b-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0) (u3 0) (u4 0))
(declare (type ub8 u2 u3 u4))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Unlike the UTF-8 version, this version of
;; CONSUME-OCTET needs to check if I is being incremented
;; past END because we might have trailing binary
;; garbage.
(macrolet
((consume-octet (n)
`(if (= i (1- end))
(encode-raw-octets ,n)
(,',getter src (incf i))))
(encode-raw-octets (n)
`(progn
,@(loop for i below n and var in '(u1 u2 u3 u4)
collect `(,',setter (logior #xdc00 ,var) dest di)
unless (= i (1- n))
collect '(incf di))
(return-from set-body))))
(block set-body
(,setter (cond
((< u1 #x80) ; 1 octet
u1)
((>= u1 #xc2)
(setq u2 (consume-octet 1))
(cond
((< u1 #xe0) ; 2 octets
(if (< (f-logxor u2 #x80) #x40)
(logior (f-ash (f-logand #x1f u1) 6)
(f-logxor u2 #x80))
(encode-raw-octets 2)))
(t
(setq u3 (consume-octet 2))
(cond
((< u1 #xf0) ; 3 octets
(if (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(or (>= u1 #xe1) (>= u2 #xa0)))
(let ((start (f-logior (f-ash (f-logand u1 #x0f) 12)
(f-ash (f-logand u2 #x3f) 6))))
(if (<= #xd800 start #xdfc0)
(encode-raw-octets 3)
(logior start (f-logand u3 #x3f))))
(encode-raw-octets 3)))
(t ; 4 octets
(setq u4 (consume-octet 3))
(if (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(< (f-logxor u4 #x80) #x40)
(or (>= u1 #xf1) (>= u2 #x90)))
(logior
(f-logior (f-ash (f-logand u1 7) 18)
(f-ash (f-logxor u2 #x80) 12))
(f-logior (f-ash (f-logxor u3 #x80) 6)
(f-logxor u4 #x80)))
(encode-raw-octets 4)))))))
(t (encode-raw-octets 1)))
dest di)))
finally (return (the fixnum (- di d-start)))))))
;;;; UTF-16
;;; TODO: add a way to pass some info at compile-time telling us that,
;;; for example, the maximum code-point will always be < #x10000 in
;;; which case we could simply return (* 2 (- end start)).
(defmacro utf16-octet-counter (getter type)
`(named-lambda utf-16-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let ((new (the fixnum (+ (if (< code #x10000) 2 4) noctets))))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(defmacro utf-16-combine-surrogate-pairs (u1 u2)
`(the (unsigned-byte 21)
(+ #x10000
(the (unsigned-byte 20)
(logior
(the (unsigned-byte 20)
(ash (the (unsigned-byte 10) (- ,u1 #xd800)) 10))
(the (unsigned-byte 10)
(- ,u2 #xdc00)))))))
(defmacro define-utf-16 (name &optional endianness)
(check-type endianness (or null (eql :be) (eql :le)))
(check-type name keyword)
(let ((swap-var (gensym "SWAP"))
(code-point-counter-name
(format-symbol t '#:~a-code-point-counter (string name)))
(encoder-name (format-symbol t '#:~a-encoder (string name)))
(decoder-name (format-symbol t '#:~a-decoder (string name))))
(labels ((make-bom-check-form (end start getter seq)
(if (null endianness)
``((,',swap-var
(when (> ,,end ,,start)
(case (,,getter ,,seq ,,start 2 :ne)
(#.+byte-order-mark-code+ (incf ,,start 2) nil)
(#.+swapped-byte-order-mark-code+ (incf ,,start 2) t)
(t #+little-endian t)))))
'()))
(make-getter-form (getter src i)
(case endianness
(:le ``(,,getter ,,src ,,i 2 :le))
(:be ``(,,getter ,,src ,,i 2 :be))
(t ``(if ,',swap-var
(,,getter ,,src ,,i 2 :re)
(,,getter ,,src ,,i 2 :ne)))))
(make-setter-form (setter code dest di)
(case endianness
(:be ``(,,setter ,,code ,,dest ,,di 2 :be))
(:le ``(,,setter ,,code ,,dest ,,di 2 :le))
(t ``(,,setter ,,code ,,dest ,,di 2 :ne)))))
`(progn
(define-octet-counter ,name (getter type)
`(utf16-octet-counter ,getter ,type))
(define-code-point-counter ,name (getter type)
`(named-lambda ,',code-point-counter-name (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(let* ,,(make-bom-check-form ''end ''start 'getter ''seq)
(loop with count fixnum = 0
with i fixnum = start
while (<= i (- end 2)) do
(let* ((code ,,(make-getter-form 'getter ''seq ''i))
(next-i (+ i (if (or (< code #xd800) (>= code #xdc00))
2
4))))
(declare (type (unsigned-byte 16) code) (fixnum next-i))
(cond
((> next-i end)
(decoding-error
(vector (,getter seq i) (,getter seq (1+ i)))
,',name seq i nil 'end-of-input-in-character)
(return (values count i)))
(t
(setq i next-i
count (1+ count))
(when (and (plusp max) (= count max))
(return (values count i))))))
finally (progn
(assert (= i end))
(return (values count i)))))))
(define-encoder ,name (getter src-type setter dest-type)
`(named-lambda ,',encoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for high-bits fixnum = (- code #x10000) do
(cond ((< high-bits 0)
,,(make-setter-form 'setter ''code ''dest ''di)
(incf di 2))
(t
,,(make-setter-form
'setter ''(logior #xd800 (f-ash high-bits -10))
''dest ''di)
,,(make-setter-form
'setter ''(logior #xdc00 (f-logand high-bits #x3ff))
''dest ''(+ di 2))
(incf di 4)))
finally (return (the fixnum (- di d-start))))))
(define-decoder ,name (getter src-type setter dest-type)
`(named-lambda ,',decoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ,,(make-bom-check-form ''end ''start 'getter ''src)
(loop with i fixnum = start
for di fixnum from d-start
until (= i end) do
(let ((u1 ,,(make-getter-form 'getter ''src ''i)))
(declare (type (unsigned-byte 16) u1))
(incf i 2)
(,setter (cond
((or (< u1 #xd800) (>= u1 #xe000)) ; 2 octets
u1)
((< u1 #xdc00) ; 4 octets
(let ((u2 ,,(make-getter-form 'getter ''src ''i)))
(declare (type (unsigned-byte 16) u2))
(incf i 2)
(if (and (>= u2 #xdc00) (< u2 #xe000))
(utf-16-combine-surrogate-pairs u1 u2)
(decoding-error
(vector (,getter src (- i 4))
(,getter src (- i 3))
(,getter src (- i 2))
(,getter src (- i 1)))
,',name src i +repl+))))
(t
(decoding-error (vector (,getter src (- i 2))
(,getter src (- i 1)))
,',name src i +repl+)))
dest di))
finally (return (the fixnum (- di d-start)))))))
',name))))
(define-character-encoding :utf-16
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The endianness of the encoded data is indicated by
the endianness of a byte-order-mark character (#\u+feff)
prepended to the data; in the absence of such a character on
input, the data is assumed to be in big-endian order. Output is
written in native byte-order with a leading byte-order mark."
:max-units-per-char 2
:code-unit-size 16
:native-endianness t ; not necessarily true when decoding
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:use-bom #+big-endian :utf-16be #+little-endian :utf-16le
:bom-encoding #+big-endian #(#xfe #xff) #+little-endian #(#xff #xfe)
:nul-encoding #(0 0)
:default-replacement #xfffd
:ambiguous #+little-endian t #+big-endian nil)
(define-utf-16 :utf-16)
(define-character-encoding :utf-16le
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The data is assumed to be in little-endian order. Output is
written in little-endian byte-order without a leading byte-order mark."
:aliases '(:utf-16/le)
:max-units-per-char 2
:code-unit-size 16
:native-endianness #+little-endian t #+big-endian nil
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:nul-encoding #(0 0)
:default-replacement #xfffd)
(define-utf-16 :utf-16le :le)
(define-character-encoding :utf-16be
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The data is assumed to be in big-endian order. Output is
written in big-endian byte-order without a leading byte-order mark."
:aliases '(:utf-16/be)
:max-units-per-char 2
:code-unit-size 16
:native-endianness #+little-endian nil #+big-endian t
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:nul-encoding #(0 0)
:default-replacement #xfffd)
(define-utf-16 :utf-16be :be)
(defmacro define-ucs (name bytes &optional endianness (limit #x110000))
(check-type name keyword)
(check-type bytes (or (eql 2) (eql 4)))
(check-type endianness (or null (eql :le) (eql :be)))
(let ((swap-var (gensym "SWAP"))
(code-point-counter-name
(format-symbol t '#:~a-code-point-counter (string name)))
(encoder-name
(format-symbol t '#:~a-encoder (string name)))
(decoder-name
(format-symbol t '#:~a-decoder (string name))))
(labels ((make-bom-check-form (end start getter src)
(if (null endianness)
``(when (not (zerop (- ,,end ,,start)))
(case (,,getter ,,src 0 ,',bytes :ne)
(#.+byte-order-mark-code+
(incf ,,start ,',bytes) nil)
(#.+swapped-byte-order-mark-code-32+
(incf ,,start ,',bytes) t)
(t #+little-endian t)))
'()))
(make-setter-form (setter code dest di)
``(,,setter ,,code ,,dest ,,di ,',bytes
,',(or endianness :ne)))
(make-getter-form (getter src i)
(if (null endianness)
``(if ,',swap-var
(,,getter ,,src ,,i ,',bytes :re)
(,,getter ,,src ,,i ,',bytes :ne))
``(,,getter ,,src ,,i ,',bytes ,',endianness))))
`(progn
(define-code-point-counter ,name (getter type)
`(named-lambda ,',code-point-counter-name (seq start end max)
(declare (type ,type seq) (fixnum start end max))
;; check for bom
,,(make-bom-check-form ''end ''start 'getter ''seq)
(multiple-value-bind (count rem)
(floor (- end start) ,',bytes)
(cond
((and (plusp max) (> count max))
(values max (the fixnum (+ start (* ,',bytes max)))))
(t
;; check for incomplete last character
(unless (zerop rem)
(let ((vector (make-array ,',bytes :fill-pointer 0)))
(dotimes (i rem)
(vector-push (,getter seq (+ i (- end rem))) vector))
(decoding-error vector ,',name seq (the fixnum (- end rem)) nil
'end-of-input-in-character)
(decf end rem)))
(values count end))))))
(define-encoder ,name (getter src-type setter dest-type)
`(named-lambda ,',encoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop for i fixnum from start below end
and di fixnum from d-start by ,',bytes
for code of-type code-point = (,getter src i)
do (if (>= code ,',limit)
(encoding-error code ,',name src i +repl+)
,,(make-setter-form 'setter ''code ''dest ''di))
finally (return (the fixnum (- di d-start))))))
(define-decoder ,name (getter src-type setter dest-type)
`(named-lambda ,',decoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((,',swap-var ,,(make-bom-check-form ''end ''start 'getter ''src)))
(declare (ignorable ,',swap-var))
(loop for i fixnum from start below end by ,',bytes
and di from d-start
do (,setter (let ((unit ,,(make-getter-form 'getter ''src ''i)))
(if (>= unit ,',limit)
(decoding-error
(vector (,getter src i)
(,getter src (+ i 1))
,@,(if (= bytes 4)
``((,getter src (+ i 2))
(,getter src (+ i 3)))))
,',name src i +repl+
'character-out-of-range)
unit))
dest di)
finally (return (the fixnum (- di d-start)))))))
',name))))
;;;; UTF-32
(define-character-encoding :utf-32
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. The
endianness of the encoded data is indicated by the endianness of
a byte-order-mark character (#\u+feff) prepended to the data; in
the absence of such a character on input, input data is assumed
to be in big-endian order. Output is written in native byte
order with a leading byte-order mark."
:aliases '(:ucs-4)
:max-units-per-char 1
:code-unit-size 32
:native-endianness t ; not necessarily true when decoding
:literal-char-code-limit #x110000
:use-bom #+little-endian :utf-32le #+big-endian :utf-32be
:bom-encoding
#+big-endian #(#x00 #x00 #xfe #xff)
#+little-endian #(#xff #xfe #x00 #x00)
:nul-encoding #(0 0 0 0)
:ambiguous #+little-endian t #+big-endian nil)
(define-ucs :utf-32 4)
(define-character-encoding :utf-32le
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. Input data is assumed
to be in little-endian order. Output is also written in little-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 32
:aliases '(:utf-32/le :ucs-4le :ucs-4/le)
:native-endianness #+little-endian t #+big-endian nil
:literal-char-code-limit #x110000
:nul-encoding #(0 0 0 0))
(define-ucs :utf-32le 4 :le)
(define-character-encoding :utf-32be
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. Input data is assumed
to be in big-endian order. Output is also written in big-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 32
:aliases '(:utf-32/be :ucs-4be :ucs-4/be)
:native-endianness #+little-endian nil #+big-endian t
:literal-char-code-limit #x110000
:nul-encoding #(0 0 0 0))
(define-ucs :utf-32be 4 :be)
;; UCS-2
(define-character-encoding :ucs-2
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. The
endianness of the encoded data is indicated by the endianness of
a byte-order-mark character (#\u+feff) prepended to the data; in
the absence of such a character on input, input data is assumed
to be in big-endian order. Output is written in native byte
order with a leading byte-order mark."
:aliases '(:ucs-2)
:max-units-per-char 1
:code-unit-size 16
:native-endianness t ; not necessarily true when decoding
:literal-char-code-limit #x10000
:use-bom #+little-endian :ucs-2le #+big-endian :ucs-2be
:bom-encoding
#+big-endian #(#xfe #xff)
#+little-endian #(#xff #xfe)
:nul-encoding #(0 0)
:ambiguous #+little-endian t #+big-endian nil)
(define-ucs :ucs-2 2 nil #x10000)
(define-character-encoding :ucs-2le
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. Input data is assumed
to be in little-endian order. Output is also written in little-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 16
:aliases '(:ucs-2/le)
:native-endianness #+little-endian t #+big-endian nil
:literal-char-code-limit #x10000
:nul-encoding #(0 0))
(define-ucs :ucs-2le 2 :le #x10000)
(define-character-encoding :ucs-2be
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. Input data is assumed
to be in big-endian order. Output is also written in big-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 16
:aliases '(:ucs-2/be)
:native-endianness #+little-endian nil #+big-endian t
:literal-char-code-limit #x10000
:nul-encoding #(0 0))
(define-ucs :ucs-2be 2 :be #x10000)

503
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/encodings.lisp Normal file
View file

@ -0,0 +1,503 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; encodings.lisp --- Character encodings and mappings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
;;;; Character Encodings
(defclass character-encoding ()
((name :initarg :name :reader enc-name
:initform (error "Must specify a NAME for this character encoding."))
;; Most of these documentation strings are taken from OpenMCL.
(documentation
:initarg :documentation :reader enc-documentation :initform nil)
;; A non-exhaustive list of aliases for the encoding.
(aliases :initarg :aliases :initform nil :reader enc-aliases)
;; Specified in bits. Usually 8, 16 or 32.
(code-unit-size
:initarg :code-unit-size :reader enc-code-unit-size :initform 8)
(max-units-per-char
:initarg :max-units-per-char :reader enc-max-units-per-char :initform 1)
;; If NIL, it is necessary to swap 16- and 32-bit units.
(native-endianness
:initarg :native-endianness :reader enc-native-endianness :initform t)
;; Code units less than this value map to themselves on input.
(decode-literal-code-unit-limit
:initarg :decode-literal-code-unit-limit :initform 0
:reader enc-decode-literal-code-unit-limit)
;; Code points less than this value map to themselves on output.
(encode-literal-code-unit-limit
:initarg :encode-literal-code-unit-limit :initform 0
:reader enc-encode-literal-code-unit-limit)
;; Defines whether it is necessary to prepend a byte-order-mark to
;; determine the endianness.
(use-bom :initarg :use-bom :initform nil :reader enc-use-bom)
;; How the byte-order-mark should be encoded, specified as a
;; sequence of octets. NIL if it cannot be encoded.
(bom-encoding
:initarg :bom-encoding :reader enc-bom-encoding :initform nil)
;; How should NUL be encoded, specified as sequence of octets.
(nul-encoding
:initarg :nul-encoding :reader enc-nul-encoding :initform #(0))
;; Preferred replacement character code point.
(default-replacement
:initarg :default-replacement :reader enc-default-replacement
:initform #x1a)
;; Does VALID-STRING => OCTETS => STRING2 guarantee a valid
;; STRING2? UTF-{16,32} on little-endian plaforms don't because
;; they assume different endianness on each direction.
(ambiguous
:initarg :ambiguous :reader ambiguous-encoding-p :initform nil)))
;;; I'm too lazy to write all the identical limits twice.
(defmethod initialize-instance :after ((enc character-encoding)
&key literal-char-code-limit)
(when literal-char-code-limit
(setf (slot-value enc 'encode-literal-code-unit-limit)
literal-char-code-limit)
(setf (slot-value enc 'decode-literal-code-unit-limit)
literal-char-code-limit)))
#-(and)
(defmethod describe-object ((enc character-encoding) s)
"Prints out the name, aliases and documentation slots of a
character encoding object."
(with-slots (name aliases documentation) enc
(format s "~&~S" name)
(when aliases
(format s " [Aliases:~{ ~S~}]" aliases))
(format s "~&~A~%~%" documentation))
(call-next-method))
(defvar *supported-character-encodings* nil)
(defun list-character-encodings ()
"List of keyword symbols denoting supported character
encodings. This list does not include aliases."
*supported-character-encodings*)
(defvar *character-encodings* (make-hash-table :test 'eq))
(defvar *default-character-encoding* :utf-8
"Special variable used to determine the default character
encoding.")
(defun get-character-encoding (name)
"Lookups the character encoding denoted by the keyword symbol
NAME. Signals an error if one is not found. If NAME is already
a CHARACTER-ENCONDING object, it is returned unmodified."
(when (typep name 'character-encoding)
(return-from get-character-encoding name))
(when (eq name :default)
(setq name *default-character-encoding*))
(or (gethash name *character-encodings*)
(error "Unknown character encoding: ~S" name)))
(defmethod ambiguous-encoding-p ((encoding symbol))
(ambiguous-encoding-p (get-character-encoding encoding)))
(defun notice-character-encoding (enc)
(pushnew (enc-name enc) *supported-character-encodings*)
(dolist (kw (cons (enc-name enc) (enc-aliases enc)))
(setf (gethash kw *character-encodings*) enc))
(enc-name enc))
(defmacro define-character-encoding (name docstring &body options)
`(notice-character-encoding
(make-instance 'character-encoding :name ,name ,@options
:documentation ,docstring)))
;;;; Mappings
;;; TODO: describe what mappings are
(defun make-fixed-width-counter (getter type &optional (unit-size-in-bits 8))
(declare (ignore getter type))
(check-type unit-size-in-bits positive-fixnum)
(let ((unit-size-in-bytes (/ unit-size-in-bits 8)))
`(named-lambda fixed-width-counter (seq start end max)
(declare (ignore seq) (fixnum start end max))
;; XXX: the result can be bigger than a fixnum when (> unit-size
;; 1) and we don't want that to happen. Possible solution: signal
;; a warning (hmm, make that an actual error) and truncate.
(if (plusp max)
(let ((count (the fixnum (min (floor max ,unit-size-in-bytes)
(the fixnum (- end start))))))
(values (the fixnum (* count ,unit-size-in-bytes))
(the fixnum (+ start count))))
(values (the fixnum (* (the fixnum (- end start))
,unit-size-in-bytes))
(the fixnum end))))))
;;; Useful to develop new encodings incrementally starting with octet
;;; and code-unit counters.
(defun make-dummy-coder (sg st ds dt)
(declare (ignore sg st ds dt))
`(named-lambda dummy-coder (src s e dest i)
(declare (ignore src s e dest i))
(error "this encoder/decoder hasn't been implemented yet")))
;;; TODO: document here
;;;
;;; ENCODER -- (lambda (src-getter src-type dest-setter dest-type) ...)
;;; DECODER -- (lambda (src-getter src-type dest-setter dest-type) ...)
;;;
;;; OCTET-COUNTER -- (lambda (getter type) ...)
;;; CODE-POINT-COUNTER -- (lambda (getter type) ...)
(defclass abstract-mapping ()
((encoder-factory :accessor encoder-factory :initform 'make-dummy-coder)
(decoder-factory :accessor decoder-factory :initform 'make-dummy-coder)
(octet-counter-factory :accessor octet-counter-factory
:initform 'make-fixed-width-counter)
(code-point-counter-factory :accessor code-point-counter-factory
:initform 'make-fixed-width-counter)))
;;; TODO: document these
;;;
;;; ENCODER -- (lambda (src start end dest d-start) ...)
;;; DECODER -- (lambda (src start end dest d-start) ...)
;;;
;;; OCTET-COUNTER -- (lambda (seq start end max-octets) ...)
;;; CODE-POINT-COUNTER -- (lambda (seq start end max-chars) ...)
;;; => N-CHARS NEW-END
;;; (important: describe NEW-END)
(defclass concrete-mapping ()
((encoder :accessor encoder)
(decoder :accessor decoder)
(octet-counter :accessor octet-counter)
(code-point-counter :accessor code-point-counter)))
(defparameter *abstract-mappings* (make-hash-table :test 'eq))
(defun get-abstract-mapping (encoding)
(gethash encoding *abstract-mappings*))
(defun (setf get-abstract-mapping) (value encoding)
(setf (gethash encoding *abstract-mappings*) value))
(defun %register-mapping-part (encoding slot-name fn)
(let ((mapping (get-abstract-mapping encoding)))
(unless mapping
(setq mapping (make-instance 'abstract-mapping))
(setf (get-abstract-mapping encoding) mapping))
(setf (slot-value mapping slot-name) fn)))
;;; See enc-*.lisp for example usages of these 4 macros.
(defmacro define-encoder (encoding (sa st da dt) &body body)
`(%register-mapping-part ,encoding 'encoder-factory
(named-lambda encoder (,sa ,st ,da ,dt)
,@body)))
(defmacro define-decoder (encoding (sa st da dt) &body body)
`(%register-mapping-part ,encoding 'decoder-factory
(named-lambda decoder (,sa ,st ,da ,dt)
,@body)))
(defmacro define-octet-counter (encoding (acc type) &body body)
`(%register-mapping-part ,encoding 'octet-counter-factory
(named-lambda octet-counter-factory (,acc ,type)
,@body)))
(defmacro define-code-point-counter (encoding (acc type) &body body)
`(%register-mapping-part ,encoding 'code-point-counter-factory
(named-lambda code-point-counter (,acc ,type)
,@body)))
(defun instantiate-encoder (encoding am octet-seq-getter octet-seq-type
code-point-seq-setter code-point-seq-type)
(declare (ignore encoding))
(funcall (encoder-factory am)
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(defun instantiate-decoder (encoding am octet-seq-getter octet-seq-type
code-point-seq-setter code-point-seq-type)
(declare (ignore encoding))
(funcall (decoder-factory am)
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(defun instantiate-code-point-counter (encoding am octet-seq-getter
octet-seq-type)
(declare (ignore encoding))
(funcall (code-point-counter-factory am)
octet-seq-getter
octet-seq-type))
(defun instantiate-octet-counter (encoding am code-point-seq-getter
code-point-seq-type)
(if (= 1 (enc-max-units-per-char encoding))
(make-fixed-width-counter code-point-seq-getter code-point-seq-type
(enc-code-unit-size encoding))
(funcall (octet-counter-factory am)
code-point-seq-getter
code-point-seq-type)))
;;; Expands into code generated by the available abstract mappings
;;; that will be compiled into concrete mappings. This is used in
;;; e.g. strings.lisp to define mappings between strings and
;;; (unsigned-byte 8) vectors.
;;;
;;; For each encoding funcall the abstract mappings at macro-expansion
;;; time with the src/dest accessors and types to generate the
;;; appropriate code for the concrete mappings. These functions are
;;; then saved in their respective slots of the CONCRETE-MAPPING
;;; object.
(defmacro instantiate-concrete-mappings
(&key (encodings (hash-table-keys *abstract-mappings*))
(optimize '((speed 3) (debug 0) (compilation-speed 0)))
octet-seq-getter octet-seq-setter octet-seq-type
code-point-seq-getter code-point-seq-setter code-point-seq-type
(instantiate-decoders t))
`(let ((ht (make-hash-table :test 'eq)))
(declare (optimize ,@optimize)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(flet ((notice-mapping (encoding-name cm)
(let* ((encoding (get-character-encoding encoding-name))
(aliases (enc-aliases encoding)))
(dolist (kw (cons (enc-name encoding) aliases))
(setf (gethash kw ht) cm)))))
,@(loop for encoding-name in encodings
for encoding = (get-character-encoding encoding-name)
for am = (gethash encoding-name *abstract-mappings*)
collect
`(let ((cm (make-instance 'concrete-mapping)))
(setf (encoder cm)
,(instantiate-encoder encoding am
code-point-seq-getter
code-point-seq-type
octet-seq-setter
octet-seq-type))
,(when instantiate-decoders
`(progn
(setf (decoder cm)
,(instantiate-decoder encoding am
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(setf (code-point-counter cm)
,(instantiate-code-point-counter
encoding am octet-seq-getter octet-seq-type))))
(setf (octet-counter cm)
,(instantiate-octet-counter encoding am
code-point-seq-getter
code-point-seq-type))
(notice-mapping ,encoding-name cm))))
ht))
;;; debugging stuff
#-(and)
(defun pprint-instantiate-concrete-mappings
(&key (encodings (hash-table-keys *abstract-mappings*))
(optimize '((debug 3) (safety 3)))
(octet-seq-setter 'ub-set) (octet-seq-getter 'ub-get)
(octet-seq-type '(simple-array (unsigned-byte 8) (*)))
(code-point-seq-setter 'string-set)
(code-point-seq-getter 'string-get)
(code-point-seq-type 'simple-unicode-string))
(let ((encodings (ensure-list encodings))
(*package* (find-package :babel-encodings))
(*print-case* :downcase))
(pprint
(macroexpand
`(instantiate-concrete-mappings
:encodings ,encodings
:optimize ,optimize
:octet-seq-getter ,octet-seq-getter
:octet-seq-setter ,octet-seq-setter
:octet-seq-type ,octet-seq-type
:code-point-seq-getter ,code-point-seq-getter
:code-point-seq-setter ,code-point-seq-setter
:code-point-seq-type ,code-point-seq-type))))
(values))
;;;; Utilities used in enc-*.lisp
(defconstant +default-substitution-code-point+ #x1a
"Default ASCII substitution character code point used in case of an encoding/decoding error.")
;;; We're converting between objects of the (UNSIGNED-BYTE 8) and
;;; (MOD #x110000) types which are aliased here to UB8 and CODE-POINT
;;; for convenience.
(deftype ub8 () '(unsigned-byte 8))
(deftype code-point () '(mod #x110000))
;;; Utility macro around DEFINE-ENCODER that takes care of most of the
;;; work need to deal with an 8-bit, fixed-width character encoding.
;;;
;;; BODY will be inside a loop and its return value will placed in the
;;; destination buffer. BODY will be surounded by lexical BLOCK which
;;; will have the ENCODING's name, usually a keyword. It handles all
;;; sorts of type declarations.
;;;
;;; See enc-ascii.lisp for a simple usage example.
(defmacro define-unibyte-encoder (encoding (code) &body body)
(with-unique-names (s-getter s-type d-setter d-type
src start end dest d-start i di)
`(define-encoder ,encoding (,s-getter ,s-type ,d-setter ,d-type)
`(named-lambda ,',(symbolicate encoding '#:-unibyte-encoder)
(,',src ,',start ,',end ,',dest ,',d-start)
(declare (type ,,s-type ,',src)
(type ,,d-type ,',dest)
(fixnum ,',start ,',end ,',d-start))
(loop for ,',i fixnum from ,',start below ,',end
and ,',di fixnum from ,',d-start do
(,,d-setter
(macrolet
;; this should probably be a function...
((handle-error (&optional (c ''character-encoding-error))
`(encoding-error
,',',code ,',',encoding ,',',src ,',',i
+default-substitution-code-point+ ,c)))
(let ((,',code (,,s-getter ,',src ,',i)))
(declare (type code-point ,',code))
(block ,',encoding ,@',body)))
,',dest ,',di)
finally (return (the fixnum (- ,',di ,',d-start))))))))
;;; The decoder version of the above macro.
(defmacro define-unibyte-decoder (encoding (octet) &body body)
(with-unique-names (s-getter s-type d-setter d-type
src start end dest d-start i di)
`(define-decoder ,encoding (,s-getter ,s-type ,d-setter ,d-type)
`(named-lambda ,',(symbolicate encoding '#:-unibyte-encoder)
(,',src ,',start ,',end ,',dest ,',d-start)
(declare (type ,,s-type ,',src)
(type ,,d-type ,',dest)
(fixnum ,',start ,',end ,',d-start))
(loop for ,',i fixnum from ,',start below ,',end
and ,',di fixnum from ,',d-start do
(,,d-setter
(macrolet
;; this should probably be a function...
((handle-error (&optional (c ''character-decoding-error))
`(decoding-error
(vector ,',',octet) ,',',encoding ,',',src ,',',i
+default-substitution-code-point+ ,c)))
(let ((,',octet (,,s-getter ,',src ,',i)))
(declare (type ub8 ,',octet))
(block ,',encoding ,@',body)))
,',dest ,',di)
finally (return (the fixnum (- ,',di ,',d-start))))))))
;;;; Error Conditions
;;;
;;; For now, we don't define any actual restarts. The only mechanism
;;; for "restarting" a coding error is the
;;; *SUPPRESS-CHARACTER-CODING-ERRORS* special variable which, when
;;; bound to T (the default), suppresses any error and uses a default
;;; replacement character instead.
;;;
;;; If it turns out that other more options are necessary, possible
;;; alternative approaches include:
;;;
;;; a) use a *REPLACEMENT-CHARACTER* special variable that lets us
;;; pick our own replacement character. The encoder must do
;;; additional work to check if this is character is encodable.
;;;
;;; b) offer a restart to pick a replacement character. Same
;;; problem as above.
;;;
;;; Both approaches pose encoding problems when dealing with a
;;; variable-width encodings because different replacement characters
;;; will need different numbers of octets. This is not a problem for
;;; UTF but will be a problem for the CJK charsets. Approach (a) is
;;; nevertheless easier since the replacement character is known in
;;; advance and therefore the octet-counter can account for it.
;;;
;;; For more complex restarts like SBCL's -- that'll let you specify
;;; _several_ replacement characters for a single character error --
;;; will probably need extra support code outside the encoder/decoder
;;; (i.e. in the string-to-octets function, for example) since the
;;; encoders/decoders deal with pre-allocated fixed-length buffers.
;;;
;;; SBCL has ASCII-specific (MALFORMED-ASCII) and UTF8-specific
;;; errors. Why? Do we want to add some of those too?
;;; FIXME: We used to deal with this with an extra ERRORP argument for
;;; encoders, decoders, etc... Still undecided on the best way to do
;;; it. We could also use a simple restart instead of this...
;;;
;;; In any case, this is not for the users to bind and it's not
;;; exported from the BABEL package.
(defvar *suppress-character-coding-errors* nil
"If non-NIL, encoding or decoding errors are suppressed and the
the current character encoding's default replacement character is
used.")
;;; All of Babel's error conditions are subtypes of
;;; CHARACTER-CODING-ERROR. This error hierarchy is based on SBCL's.
(define-condition character-coding-error (error)
((buffer :initarg :buffer :reader character-coding-error-buffer)
(position :initarg :position :reader character-coding-error-position)
(encoding :initarg :encoding :reader character-coding-error-encoding)))
(define-condition character-encoding-error (character-coding-error)
((code :initarg :code :reader character-encoding-error-code))
(:report (lambda (c s)
(format s "Unable to encode character code point ~A as ~S."
(character-encoding-error-code c)
(character-coding-error-encoding c)))))
(declaim (inline encoding-error))
(defun encoding-error (code enc buf pos &optional
(sub +default-substitution-code-point+)
(e 'character-encoding-error))
(unless *suppress-character-coding-errors*
(error e :encoding enc :buffer buf :position pos :code code))
sub)
(define-condition character-decoding-error (character-coding-error)
((octets :initarg :octets :reader character-decoding-error-octets))
(:report (lambda (c s)
(format s "Illegal ~S character starting at position ~D."
(character-coding-error-encoding c)
(character-coding-error-position c)))))
(define-condition end-of-input-in-character (character-decoding-error)
()
(:documentation "Signalled by DECODERs or CODE-POINT-COUNTERs
of variable-width character encodings."))
(define-condition character-out-of-range (character-decoding-error)
()
(:documentation
"Signalled when the character being decoded is out of range."))
(declaim (inline decoding-error))
(defun decoding-error (octets enc buf pos &optional
(sub +default-substitution-code-point+)
(e 'character-decoding-error))
(unless *suppress-character-coding-errors*
(error e :octets octets :encoding enc :buffer buf :position pos))
sub)

88
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/external-format.lisp Normal file
View file

@ -0,0 +1,88 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; external-format.lisp --- External format classes and functions.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
(defvar *default-eol-style*
#+windows :crlf
#-windows :lf
"The end-of-line style used by external formats if none is
explicitly given. Depends on the OS the code is compiled on.")
(deftype eol-style ()
"Possible end-of-line styles."
'(member :cr :lf :crlf))
(defclass external-format ()
((encoding :initarg :encoding :reader external-format-encoding
:type character-encoding)
(eol-style :initarg :eol-style :reader external-format-eol-style
:type eol-style :initform *default-eol-style*))
(:documentation
"An EXTERNAL-FORMAT consists in a combination of a Babel
CHARACTER-ENCODING and an end-of-line style."))
(defmethod print-object ((ef external-format) stream)
(print-unreadable-object (ef stream :type t :identity t)
(format stream "~A ~A"
(enc-name (external-format-encoding ef))
(external-format-eol-style ef))))
;;; This interface is still somewhat sketchy. The rest of Babel
;;; doesn't really understand external formats, for instance.
(defun make-external-format (encoding &key (eol-style *default-eol-style*))
(check-type eol-style eol-style)
(make-instance 'external-format
:encoding (get-character-encoding encoding)
:eol-style eol-style))
(defun ensure-external-format (thing)
(etypecase thing
(external-format thing)
(character-encoding (make-instance 'external-format :encoding thing))
(symbol (make-external-format thing))
(list (apply #'make-external-format thing))))
(defun external-format-equal (ef1 ef2)
(and (eq (external-format-encoding ef1) (external-format-encoding ef2))
(eq (external-format-eol-style ef1) (external-format-eol-style ef2))))
(declaim (inline lookup-mapping))
(defun lookup-mapping (ht encoding)
"HT should be an hashtable created by
INSTANTIATE-CONCRETE-MAPPINGS. ENCODING should be either an
external format, an encoding object or a keyword symbol
denoting a character encoding name or one of its aliases."
(or (etypecase encoding
(keyword
(gethash encoding ht))
(babel-encodings::concrete-mapping
encoding)
(character-encoding
(gethash (enc-name encoding) ht))
(external-format
(gethash (enc-name (external-format-encoding encoding)) ht)))
(error "~S is not a valid encoding designator" encoding)))

2226
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/gbk-map.lisp Normal file
View file

File diff suppressed because it is too large Load diff

17637
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/jpn-table.lisp Normal file
View file

File diff suppressed because it is too large Load diff

115
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/packages.lisp Normal file
View file

@ -0,0 +1,115 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- Package definition for Babel
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:cl-user)
(defpackage #:babel-encodings
(:use #:common-lisp #:alexandria)
(:export
;; character encoding objects
#:list-character-encodings
#:character-encoding
#:*default-character-encoding*
#:get-character-encoding
#:enc-name
#:enc-aliases
#:enc-code-unit-size
#:enc-max-units-per-char
#:enc-native-endianness
#:enc-decode-literal-code-unit-limit
#:enc-encode-literal-code-unit-limit
#:enc-use-bom
#:enc-bom-encoding
#:enc-nul-encoding
#:enc-default-replacement
#:ambiguous-encoding-p
;; concrete mappings
#:instantiate-concrete-mappings
#:encoder
#:decoder
#:octet-counter
#:code-point-counter
#:lookup-mapping
#:with-simple-vector
#:with-checked-simple-vector
#:*suppress-character-coding-errors*
;; errors
#:character-coding-error
#:character-coding-error-encoding ; accessor
#:character-coding-error-buffer ; accessor
#:character-coding-error-position ; accessor
#:character-decoding-error
#:character-decoding-error-octets ; accessor
#:character-encoding-error
#:character-encoding-error-code ; accessor
#:end-of-input-in-character
#:character-out-of-range
#:invalid-utf8-starter-byte
#:invalid-utf8-continuation-byte
#:overlong-utf8-sequence))
(defpackage #:babel
(:use #:common-lisp #:babel-encodings #:alexandria)
(:import-from #:babel-encodings)
(:export
;; types
#:unicode-char
#:unicode-char-code-limit
#:unicode-string
#:simple-unicode-string
;; fixed sharp-backslash reader
#:enable-sharp-backslash-syntax
#:set-sharp-backslash-syntax-in-readtable
;; external formats
#:external-format
#:make-external-format
#:ensure-external-format
#:external-format-encoding
#:external-format-eol-style
#:external-format-equal
#:*default-eol-style*
;; general user API
#:*default-character-encoding*
#:list-character-encodings
#:string-to-octets
#:octets-to-string
#:concatenate-strings-to-octets
#:string-size-in-octets
#:vector-size-in-chars
;; errors
#:character-coding-error
#:character-coding-error-encoding ; accessor
#:character-coding-error-buffer ; accessor
#:character-coding-error-position ; accessor
#:character-decoding-error
#:character-decoding-error-octets ; accessor
#:character-encoding-error
#:character-encoding-error-code ; accessor
#:end-of-input-in-character
#:character-out-of-range
#:invalid-utf8-starter-byte
#:invalid-utf8-continuation-byte
#:overlong-utf8-sequence))

82
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/sharp-backslash.lisp Normal file
View file

@ -0,0 +1,82 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; sharp-backslash.lisp --- Alternative #\ dispatch code.
;;;
;;; Copyright (C) 2007-2009, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
#-allegro
(defun sharp-backslash-reader (original-reader stream char numarg)
(let ((1st-char (read-char stream)))
(if (and (char-equal 1st-char #\u)
;; because #\z is not a digit char...
(digit-char-p (peek-char nil stream nil #\z) 16))
;; something better than READ would be nice here
(let ((token (let ((*read-base* 16)) (read stream))))
(if (typep token 'babel-encodings::code-point)
(code-char token)
(if *read-suppress*
nil
(simple-reader-error
stream "Unrecognized character name: u~A" token))))
(funcall original-reader
(make-concatenated-stream (make-string-input-stream
(string 1st-char))
stream)
char
numarg))))
;;; Allegro's PEEK-CHAR seems broken in some situations, and the code
;;; above would generate an error about too many calls to UNREAD-CHAR.
;;; Then Allegro's original SHARP-BACKSLASH wants to UNREAD-CHAR
;;; twice, very weird. This is the best workaround I could think of.
;;; It sucks.
#+allegro
(defun sharp-backslash-reader (original-reader stream char numarg)
(let* ((1st-char (read-char stream))
(rest (ignore-errors (excl::read-extended-token stream)))
(code (when (and rest (char-equal 1st-char #\u))
(ignore-errors (parse-integer rest :radix 16)))))
(if code
(code-char code)
(with-input-from-string
(s (concatenate 'string "#\\" (string 1st-char) rest))
(read-char s)
(read-char s)
(funcall original-reader s char numarg)))))
(defun make-sharp-backslash-reader ()
(let ((original-sharp-backslash (get-dispatch-macro-character #\# #\\)))
(lambda (stream char numarg)
(sharp-backslash-reader original-sharp-backslash stream char numarg))))
(defmacro enable-sharp-backslash-syntax ()
`(eval-when (:compile-toplevel :execute)
(setf *readtable* (copy-readtable *readtable*))
(set-sharp-backslash-syntax-in-readtable)
(values)))
(defun set-sharp-backslash-syntax-in-readtable ()
(set-dispatch-macro-character #\# #\\ (make-sharp-backslash-reader))
(values))

436
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/streams.lisp Normal file
View file

@ -0,0 +1,436 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; streams.lisp --- Conversions between strings and UB8 vectors.
;;;
;;; Copyright (c) 2005-2007, Dr. Edmund Weitz. All rights reserved.
;;; Copyright (c) 2008, Attila Lendvai. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; STATUS
;;;
;;; - in-memory output streams support binary/bivalent/character
;;; element-types and file-position
;;; TODO
;;;
;;; - filter-stream types/mixins that can wrap a binary stream and
;;; turn it into a bivalent/character stream
;;; - in-memory input streams with file-position similar to in-memory
;;; output streams
;;; - in-memory input/output streams?
(in-package #:babel)
(defpackage #:babel-streams
(:use #:common-lisp #:babel #:trivial-gray-streams #:alexandria)
(:export
#:in-memory-stream
#:vector-output-stream
#:vector-input-stream
#:make-in-memory-output-stream
#:make-in-memory-input-stream
#:get-output-stream-sequence
#:with-output-to-sequence
#:with-input-from-sequence))
(in-package :babel-streams)
(declaim (inline check-if-open check-if-accepts-octets
check-if-accepts-characters stream-accepts-characters?
stream-accepts-octets? vector-extend
extend-vector-output-stream-buffer))
(defgeneric get-output-stream-sequence (stream &key &allow-other-keys))
;;;; Some utilities (on top due to inlining)
(defun vector-extend (extension vector &key (start 0) (end (length extension)))
;; copied over from cl-quasi-quote
(declare (optimize speed)
(type vector extension vector)
(type array-index start end))
(let* ((original-length (length vector))
(extension-length (- end start))
(new-length (+ original-length extension-length))
(original-dimension (array-dimension vector 0)))
(when (< original-dimension new-length)
(setf vector
(adjust-array vector (max (* 2 original-dimension) new-length))))
(setf (fill-pointer vector) new-length)
(replace vector extension :start1 original-length :start2 start :end2 end)
vector))
(defclass in-memory-stream (trivial-gray-stream-mixin)
((element-type ; :default means bivalent
:initform :default :initarg :element-type :accessor element-type-of)
(external-format
:initform (ensure-external-format *default-character-encoding*)
:initarg :external-format :accessor external-format-of)
#+cmu
(open-p
:initform t :accessor in-memory-stream-open-p
:documentation "For CMUCL we have to keep track of this manually."))
(:documentation "An IN-MEMORY-STREAM is a binary stream that reads octets
from or writes octets to a sequence in RAM."))
(defmethod stream-element-type ((self in-memory-stream))
;; stream-element-type is a CL symbol, we may not install an accessor on it.
;; so, go through this extra step.
(element-type-of self))
(defun stream-accepts-octets? (stream)
(let ((element-type (element-type-of stream)))
(or (eq element-type :default)
(equal element-type '(unsigned-byte 8))
(subtypep element-type '(unsigned-byte 8)))))
(defun stream-accepts-characters? (stream)
(let ((element-type (element-type-of stream)))
(member element-type '(:default character base-char))))
(defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
()
(:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that reads
octets from a sequence in RAM."))
#+cmu
(defmethod output-stream-p ((stream in-memory-input-stream))
"Explicitly states whether this is an output stream."
(declare (optimize speed))
nil)
(defclass in-memory-output-stream (in-memory-stream
fundamental-binary-output-stream)
()
(:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
writes octets to a sequence in RAM."))
#+cmu
(defmethod input-stream-p ((stream in-memory-output-stream))
"Explicitly states whether this is an input stream."
(declare (optimize speed))
nil)
(defun make-in-memory-output-stream (&key (element-type :default)
external-format
initial-buffer-size)
"Returns a binary output stream which accepts objects of type
ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence that
contains the octes that were actually output."
(declare (optimize speed))
(unless external-format
(setf external-format *default-character-encoding*))
(when (eq element-type :bivalent)
(setf element-type :default))
(make-instance 'vector-output-stream
:vector (make-vector-stream-buffer
:element-type
(cond
((or (eq element-type :default)
(equal element-type '(unsigned-byte 8)))
'(unsigned-byte 8))
((eq element-type 'character)
'character)
((subtypep element-type '(unsigned-byte 8))
'(unsigned-byte 8))
(t (error "Illegal element-type ~S" element-type)))
:initial-size initial-buffer-size)
:element-type element-type
:external-format (ensure-external-format external-format)))
(defun make-in-memory-input-stream (data &key (element-type :default)
external-format)
"Returns a binary input stream which provides the elements of DATA when read."
(declare (optimize speed))
(unless external-format
(setf external-format *default-character-encoding*))
(when (eq element-type :bivalent)
(setf element-type :default))
(make-instance 'vector-input-stream
:vector data
:element-type element-type
:end (length data)
:external-format (ensure-external-format external-format)))
(defclass vector-stream ()
((vector
:initarg :vector :accessor vector-stream-vector
:documentation "The underlying vector of the stream which \(for output)
must always be adjustable and have a fill pointer.")
(index
:initform 0 :initarg :index :accessor vector-stream-index
:type (integer 0 #.array-dimension-limit)
:documentation "An index into the underlying vector denoting the
current position."))
(:documentation
"A VECTOR-STREAM is a mixin for IN-MEMORY streams where the underlying
sequence is a vector."))
(defclass vector-input-stream (vector-stream in-memory-input-stream)
((end
:initarg :end :accessor vector-stream-end
:type (integer 0 #.array-dimension-limit)
:documentation "An index into the underlying vector denoting the end
of the available data."))
(:documentation "A binary input stream that gets its data from an
associated vector of octets."))
(defclass vector-output-stream (vector-stream in-memory-output-stream)
()
(:documentation
"A binary output stream that writes its data to an associated vector."))
(define-condition in-memory-stream-error (stream-error)
()
(:documentation "Superclass for all errors related to IN-MEMORY streams."))
(define-condition in-memory-stream-closed-error (in-memory-stream-error)
()
(:report (lambda (condition stream)
(format stream "~S is closed."
(stream-error-stream condition))))
(:documentation "An error that is signalled when someone is trying to read
from or write to a closed IN-MEMORY stream."))
(define-condition wrong-element-type-stream-error (stream-error)
((expected-type :accessor expected-type-of :initarg :expected-type))
(:report (lambda (condition output)
(let ((stream (stream-error-stream condition)))
(format output "The element-type of ~S is ~S while expecting ~
a stream that accepts ~S."
stream (element-type-of stream)
(expected-type-of condition))))))
(defun wrong-element-type-stream-error (stream expected-type)
(error 'wrong-element-type-stream-error
:stream stream :expected-type expected-type))
#+cmu
(defmethod open-stream-p ((stream in-memory-stream))
"Returns a true value if STREAM is open. See ANSI standard."
(declare (optimize speed))
(in-memory-stream-open-p stream))
#+cmu
(defmethod close ((stream in-memory-stream) &key abort)
"Closes the stream STREAM. See ANSI standard."
(declare (ignore abort) (optimize speed))
(prog1
(in-memory-stream-open-p stream)
(setf (in-memory-stream-open-p stream) nil)))
(defun check-if-open (stream)
"Checks if STREAM is open and signals an error otherwise."
(declare (optimize speed))
(unless (open-stream-p stream)
(error 'in-memory-stream-closed-error :stream stream)))
(defun check-if-accepts-octets (stream)
(declare (optimize speed))
(unless (stream-accepts-octets? stream)
(wrong-element-type-stream-error stream '(unsigned-byte 8))))
(defun check-if-accepts-characters (stream)
(declare (optimize speed))
(unless (stream-accepts-characters? stream)
(wrong-element-type-stream-error stream 'character)))
(defmethod stream-read-byte ((stream vector-input-stream))
"Reads one byte and increments INDEX pointer unless we're beyond END pointer."
(declare (optimize speed))
(check-if-open stream)
(let ((index (vector-stream-index stream)))
(cond ((< index (vector-stream-end stream))
(incf (vector-stream-index stream))
(aref (vector-stream-vector stream) index))
(t :eof))))
#+#:ignore
(defmethod stream-read-char ((stream vector-input-stream))
;; TODO
)
(defmethod stream-listen ((stream vector-input-stream))
"Checking whether INDEX is beyond END."
(declare (optimize speed))
(check-if-open stream)
(< (vector-stream-index stream) (vector-stream-end stream)))
(defmethod stream-read-sequence ((stream vector-input-stream)
sequence start end &key)
(declare (optimize speed) (type array-index start end))
;; TODO check the sequence type, assert for the element-type and use
;; the external-format.
(loop with vector-end of-type array-index = (vector-stream-end stream)
with vector = (vector-stream-vector stream)
for index from start below end
for vector-index of-type array-index = (vector-stream-index stream)
while (< vector-index vector-end)
do (setf (elt sequence index)
(aref vector vector-index))
(incf (vector-stream-index stream))
finally (return index)))
(defmethod stream-write-byte ((stream vector-output-stream) byte)
"Writes a byte \(octet) by extending the underlying vector."
(declare (optimize speed))
(check-if-open stream)
(check-if-accepts-octets stream)
(vector-push-extend byte (vector-stream-vector stream))
(incf (vector-stream-index stream))
byte)
(defun extend-vector-output-stream-buffer (extension stream &key (start 0)
(end (length extension)))
(declare (optimize speed)
(type array-index start end)
(type vector extension))
(vector-extend extension (vector-stream-vector stream) :start start :end end)
(incf (vector-stream-index stream) (- end start))
(values))
(defmethod stream-write-char ((stream vector-output-stream) char)
(declare (optimize speed))
(check-if-open stream)
(check-if-accepts-characters stream)
;; TODO this is naiive here, there's room for optimization
(let ((octets (string-to-octets (string char)
:encoding (external-format-of stream))))
(extend-vector-output-stream-buffer octets stream))
char)
(defmethod stream-write-sequence ((stream vector-output-stream)
sequence start end &key)
"Just calls VECTOR-PUSH-EXTEND repeatedly."
(declare (optimize speed)
(type array-index start end))
(etypecase sequence
(string
(if (stream-accepts-octets? stream)
;; TODO this is naiive here, there's room for optimization
(let ((octets (string-to-octets sequence
:encoding (external-format-of stream)
:start start
:end end)))
(extend-vector-output-stream-buffer octets stream))
(progn
(assert (stream-accepts-characters? stream))
(extend-vector-output-stream-buffer sequence stream
:start start :end end))))
((vector (unsigned-byte 8))
;; specialized branch to help inlining
(check-if-accepts-octets stream)
(extend-vector-output-stream-buffer sequence stream :start start :end end))
(vector
(check-if-accepts-octets stream)
(extend-vector-output-stream-buffer sequence stream :start start :end end)))
sequence)
(defmethod stream-write-string ((stream vector-output-stream)
string &optional (start 0) (end (length string)))
(stream-write-sequence stream string start (or end (length string))))
(defmethod stream-line-column ((stream vector-output-stream))
"Dummy line-column method that always returns NIL. Needed for
character output streams."
nil)
(defmethod stream-file-position ((stream vector-stream))
"Simply returns the index into the underlying vector."
(declare (optimize speed))
(vector-stream-index stream))
(defun make-vector-stream-buffer (&key (element-type '(unsigned-byte 8))
initial-size)
"Creates and returns an array which can be used as the underlying vector
for a VECTOR-OUTPUT-STREAM."
(declare (optimize speed)
(type (or null array-index) initial-size))
(make-array (the array-index (or initial-size 32))
:adjustable t
:fill-pointer 0
:element-type element-type))
(defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key (return-as 'vector))
"Returns a vector containing, in order, all the octets that have
been output to the IN-MEMORY stream STREAM. This operation clears any
octets on STREAM, so the vector contains only those octets which have
been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
the creation of the stream, whichever occurred most recently. If
AS-LIST is true the return value is coerced to a list."
(declare (optimize speed))
(prog1
(ecase return-as
(vector (vector-stream-vector stream))
(string (octets-to-string (vector-stream-vector stream)
:encoding (external-format-of stream)))
(list (coerce (vector-stream-vector stream) 'list)))
(setf (vector-stream-vector stream) (make-vector-stream-buffer))))
(defmacro with-output-to-sequence
((var &key (return-as ''vector) (element-type '':default)
(external-format '*default-character-encoding*) initial-buffer-size)
&body body)
"Creates an IN-MEMORY output stream, binds VAR to this stream and
then executes the code in BODY. The stream stores data of type
ELEMENT-TYPE \(a subtype of OCTET). The stream is automatically closed
on exit from WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is
normal or abnormal. The return value of this macro is a vector \(or a
list if AS-LIST is true) containing the octets that were sent to the
stream within BODY."
(multiple-value-bind (body declarations) (parse-body body)
;; this is here to stop SBCL complaining about binding them to NIL
`(let ((,var (make-in-memory-output-stream
:element-type ,element-type
:external-format ,external-format
:initial-buffer-size ,initial-buffer-size)))
,@declarations
(unwind-protect
(progn
,@body
(get-output-stream-sequence ,var :return-as ,return-as))
(close ,var)))))
(defmacro with-input-from-sequence
((var data &key (element-type '':default)
(external-format '*default-character-encoding*))
&body body)
"Creates an IN-MEMORY input stream that will return the values
available in DATA, binds VAR to this stream and then executes the code
in BODY. The stream stores data of type ELEMENT-TYPE \(a subtype of
OCTET). The stream is automatically closed on exit from
WITH-INPUT-FROM-SEQUENCE, no matter whether the exit is normal or
abnormal. The return value of this macro is the return value of BODY."
(multiple-value-bind (body declarations) (parse-body body)
;; this is here to stop SBCL complaining about binding them to NIL
`(let ((,var (make-in-memory-input-stream
,data :element-type ,element-type
:external-format ,external-format)))
,@declarations
(unwind-protect
(progn
,@body)
(close ,var)))))

353
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/strings.lisp Normal file
View file

@ -0,0 +1,353 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Conversions between strings and UB8 vectors.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
;;; The usefulness of this string/octets interface of Babel's is very
;;; limited on Lisps with 8-bit characters which will in effect only
;;; support the latin-1 subset of Unicode. That is, all encodings are
;;; supported but we can only store the first 256 code points in Lisp
;;; strings. Support for using other 8-bit encodings for strings on
;;; these Lisps could be added with an extra encoding/decoding step.
;;; Supporting other encodings with larger code units would be silly
;;; (it would break expectations about common string operations) and
;;; better done with something like Closure's runes.
;;; Can we handle unicode fully?
(eval-when (:compile-toplevel :load-toplevel :execute)
;; The EVAL is just here to avoid warnings...
(case (eval char-code-limit)
(#x100 (pushnew '8-bit-chars *features*))
(#x10000 (pushnew 'ucs-2-chars *features*))
(#x110000 #| yay |#)
;; This is here mostly because if the CHAR-CODE-LIMIT is bigger
;; than #x11000, strange things might happen but we probably
;; shouldn't descriminate against other, smaller, values.
(t (error "Strange CHAR-CODE-LIMIT (#x~X), bailing out."
char-code-limit))))
;;; Adapted from Ironclad. TODO: check if it's worthwhile adding
;;; implementation-specific accessors such as SAP-REF-* for SBCL.
(defmacro ub-get (vector index &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
(once-only (vector index)
`(logand
,(1- (ash 1 (* 8 bytes)))
(logior
,@(loop for i from 0 below bytes
for offset = (if big-endian i (- bytes i 1))
for shift = (if big-endian
(* (- bytes i 1) 8)
(* offset 8))
collect `(ash (aref ,vector (+ ,index ,offset)) ,shift)))))))
(defmacro ub-set (value vector index &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
`(progn
,@(loop for i from 1 to bytes
for offset = (if big-endian (- bytes i) (1- i)) collect
`(setf (aref ,vector (+ ,index ,offset))
(ldb (byte 8 ,(* 8 (1- i))) ,value)))
(values))))
(defmacro string-get (string index)
`(char-code (schar ,string ,index)))
(defmacro string-set (code string index)
`(setf (schar ,string ,index) (code-char ,code)))
;;; SIMPLE-BASE-STRING would also be a subtype of SIMPLE-STRING so we
;;; don't use that because on SBCL BASE-CHARs can only hold ASCII.
;;; Also, with (> SPEED SAFETY) (setf (schar base-str n) big-char)
;;; will quietly work, sort of.
;;;
;;; XXX: test this on various lisps.
(defconstant unicode-char-code-limit
char-code-limit
"An alias for CL:CHAR-CODE-LIMIT which might be lower than
#x110000 on some Lisps.")
(deftype unicode-char ()
"This character type can hold any characters whose CHAR-CODEs
are less than UNICODE-CHAR-CODE-LIMIT."
#+lispworks 'lw:simple-char
#-lispworks 'character)
(deftype simple-unicode-string ()
"Alias for (SIMPLE-ARRAY UNICODE-CHAR (*))."
'(simple-array unicode-char (*)))
(deftype unicode-string ()
"Alias for (VECTOR UNICODE-CHAR *)."
'(vector unicode-char *))
(defparameter *string-vector-mappings*
(instantiate-concrete-mappings
;; :optimize ((speed 3) (safety 0) (debug 0) (compilation-speed 0))
:octet-seq-setter ub-set
:octet-seq-getter ub-get
:octet-seq-type (simple-array (unsigned-byte 8) (*))
:code-point-seq-setter string-set
:code-point-seq-getter string-get
:code-point-seq-type simple-unicode-string))
#+sbcl
(defparameter *simple-base-string-vector-mappings*
(instantiate-concrete-mappings
;; :optimize ((speed 3) (safety 0) (debug 0) (compilation-speed 0))
:instantiate-decoders nil
:octet-seq-setter ub-set
:octet-seq-getter ub-get
:octet-seq-type (simple-array (unsigned-byte 8) (*))
:code-point-seq-setter string-set
:code-point-seq-getter string-get
:code-point-seq-type simple-base-string))
;;; Do we want a more a specific error condition here?
(defun check-vector-bounds (vector start end)
(unless (<= 0 start end (length vector))
(error "Invalid start (~A) and end (~A) values for vector of length ~A."
start end (length vector))))
(defmacro with-simple-vector (((v vector) (s start) (e end)) &body body)
"If VECTOR is a displaced or adjustable array, binds V to the
underlying simple vector, adds an adequate offset to START and
END and binds those offset values to S and E. Otherwise, if
VECTOR is already a simple array, it's simply bound to V with no
further changes.
START and END are unchecked and assumed to be within bounds.
Note that in some Lisps, a slow copying implementation is
necessary to obtain a simple vector thus V will be bound to a
copy of VECTOR coerced to a simple-vector. Therefore, you
shouldn't attempt to modify V."
#+sbcl
`(sb-kernel:with-array-data ((,v ,vector) (,s ,start) (,e ,end))
,@body)
#+(or cmu scl)
`(lisp::with-array-data ((,v ,vector) (,s ,start) (,e ,end))
,@body)
#+openmcl
(with-unique-names (offset)
`(multiple-value-bind (,v ,offset)
(ccl::array-data-and-offset ,vector)
(let ((,s (+ ,start ,offset))
(,e (+ ,end ,offset)))
,@body)))
#+allegro
(with-unique-names (offset)
`(excl::with-underlying-simple-vector (,vector ,v ,offset)
(let ((,e (+ ,end ,offset))
(,s (+ ,start ,offset)))
,@body)))
;; slow, copying implementation
#-(or sbcl cmu scl openmcl allegro)
(once-only (vector)
`(funcall (if (adjustable-array-p ,vector)
#'call-with-array-data/copy
#'call-with-array-data/fast)
,vector ,start ,end
(lambda (,v ,s ,e) ,@body))))
#-(or sbcl cmu scl openmcl allegro)
(progn
;; Stolen from f2cl.
(defun array-data-and-offset (array)
(loop with offset = 0 do
(multiple-value-bind (displaced-to index-offset)
(array-displacement array)
(when (null displaced-to)
(return-from array-data-and-offset
(values array offset)))
(incf offset index-offset)
(setf array displaced-to))))
(defun call-with-array-data/fast (vector start end fn)
(multiple-value-bind (data offset)
(array-data-and-offset vector)
(funcall fn data (+ offset start) (+ offset end))))
(defun call-with-array-data/copy (vector start end fn)
(funcall fn (replace (make-array (- end start) :element-type
(array-element-type vector))
vector :start2 start :end2 end)
0 (- end start))))
(defmacro with-checked-simple-vector (((v vector) (s start) (e end)) &body body)
"Like WITH-SIMPLE-VECTOR but bound-checks START and END."
(once-only (vector start)
`(let ((,e (or ,end (length ,vector))))
(check-vector-bounds ,vector ,start ,e)
(with-simple-vector ((,v ,vector) (,s ,start) (,e ,e))
,@body))))
;;; Future features these functions should have:
;;;
;;; * null-terminate
;;; * specify target vector/string + offset
;;; * documentation :)
(declaim (inline octets-to-string string-to-octets string-size-in-octets
vector-size-in-chars concatenate-strings-to-octets
bom-vector))
(defun octets-to-string (vector &key (start 0) end
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type vector (vector (unsigned-byte 8)))
(with-checked-simple-vector ((vector vector) (start start) (end end))
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
(let ((*suppress-character-coding-errors* (not errorp))
(mapping (lookup-mapping *string-vector-mappings* encoding)))
(multiple-value-bind (size new-end)
(funcall (code-point-counter mapping) vector start end -1)
;; TODO we could optimize ASCII here: the result should
;; be a simple-base-string filled using code-char...
(let ((string (make-string size :element-type 'unicode-char)))
(funcall (decoder mapping) vector start new-end string 0)
string)))))
(defun bom-vector (encoding use-bom)
(check-type use-bom (member :default t nil))
(the simple-vector
(if (null use-bom)
#()
(let ((enc (typecase encoding
(external-format (external-format-encoding encoding))
(t (get-character-encoding encoding)))))
(if (or (eq use-bom t)
(and (eq use-bom :default) (enc-use-bom enc)))
;; VALUES avoids a "type assertion too complex to check" note.
(values (enc-bom-encoding enc))
#())))))
(defun string-to-octets (string &key (encoding *default-character-encoding*)
(start 0) end (use-bom :default)
(errorp (not *suppress-character-coding-errors*)))
(declare (optimize (speed 3) (safety 2)))
(let ((*suppress-character-coding-errors* (not errorp)))
(etypecase string
;; On some lisps (e.g. clisp and ccl) all strings are BASE-STRING and all
;; characters are BASE-CHAR. So, only enable this optimization for
;; selected targets.
#+sbcl
(simple-base-string
(unless end
(setf end (length string)))
(check-vector-bounds string start end)
(let* ((mapping (lookup-mapping *simple-base-string-vector-mappings*
encoding))
(bom (bom-vector encoding use-bom))
(bom-length (length bom))
;; OPTIMIZE: we could use the (length string) information here
;; because it's a simple-base-string where each character <= 127
(result (make-array
(+ (the array-index
(funcall (the function (octet-counter mapping))
string start end -1))
bom-length)
:element-type '(unsigned-byte 8))))
(replace result bom)
(funcall (the function (encoder mapping))
string start end result bom-length)
result))
(string
;; FIXME: we shouldn't really need that coercion to UNICODE-STRING
;; but we kind of because it's declared all over. To avoid that,
;; we'd need different types for input and output strings. Or maybe
;; this is not a problem; figure that out.
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start start) (end end))
(declare (type simple-unicode-string string))
(let* ((mapping (lookup-mapping *string-vector-mappings* encoding))
(bom (bom-vector encoding use-bom))
(bom-length (length bom))
(result (make-array
(+ (the array-index
(funcall (the function (octet-counter mapping))
string start end -1))
bom-length)
:element-type '(unsigned-byte 8))))
(replace result bom)
(funcall (the function (encoder mapping))
string start end result bom-length)
result))))))
(defun concatenate-strings-to-octets (encoding &rest strings)
"Optimized equivalent of
\(string-to-octets \(apply #'concatenate 'string strings)
:encoding encoding)"
(declare (dynamic-extent strings))
(let* ((mapping (lookup-mapping *string-vector-mappings* encoding))
(octet-counter (octet-counter mapping))
(vector (make-array
(the array-index
(reduce #'+ strings
:key (lambda (string)
(funcall octet-counter
string 0 (length string) -1))))
:element-type '(unsigned-byte 8)))
(current-index 0))
(declare (type array-index current-index))
(dolist (string strings)
(check-type string string)
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start 0) (end (length string)))
(declare (type simple-unicode-string string))
(incf current-index
(funcall (encoder mapping)
string start end vector current-index))))
vector))
(defun string-size-in-octets (string &key (start 0) end (max -1 maxp)
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type string string)
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start start) (end end))
(declare (type simple-unicode-string string))
(let ((mapping (lookup-mapping *string-vector-mappings* encoding))
(*suppress-character-coding-errors* (not errorp)))
(when maxp (assert (plusp max)))
(funcall (octet-counter mapping) string start end max))))
(defun vector-size-in-chars (vector &key (start 0) end (max -1 maxp)
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type vector (vector (unsigned-byte 8)))
(with-checked-simple-vector ((vector vector) (start start) (end end))
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
(let ((mapping (lookup-mapping *string-vector-mappings* encoding))
(*suppress-character-coding-errors* (not errorp)))
(when maxp (assert (plusp max)))
(funcall (code-point-counter mapping) vector start end max))))
(declaim (notinline octets-to-string string-to-octets string-size-in-octets
vector-size-in-chars concatenate-strings-to-octets))

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/ascii.txt Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
Markus Kuhn [maks kun] <http://www.cl.cam.ac.uk/~mgk25/> 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
Eda = Q, n , f(i) = g(i),
a+b
x: x = x, = ( ),
c
,
< a b c d (A B),
a-b
2H + O 2HO, R = 4.7 k, 200 mm i=1
Linguistics and dictionaries:
i ntnnl fntk sosien
Y [psiln], Yen [jn], Yoga [jog]
APL:
((VV)=V)/V,V
Nicer typography in plain text files:
single and double quotes
Curly apostrophes: Weve been here
Latin-1 apostrophe and accents: '`
deutsche Anfhrungszeichen
, , , , 34, , 5/+5, ,
ASCII safety test: 1lI|, 0OD, 8B
the euro symbol: 14.95
Combining characters:
STARGTE SG-1, a = v = r, a b
Greek (in Polytonic):
The Greek anthem:
,
.
, , !
From a speech of Demosthenes in the 4th century BC:
, ,
,
,
.
, ,
. ,
, ,
,
. ,
,
.
,
Georgian:
From a Unicode conference invitation:
Unicode-
, 10-12 ,
. , .
Unicode-,
, Unicode-
, , ,
.
Russian:
From a Unicode conference invitation:
Unicode, 10-12 1997 .
Unicode, ,
Unicode
, , .
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
Runes:
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz
Greetings in various languages:
Hello world, ,
Box drawing alignment tests:

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/ascii.txt-utf8 Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
Markus Kuhn [maks kun] <http://www.cl.cam.ac.uk/~mgk25/> 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
Eda = Q, n , f(i) = g(i),
a+b
x: x = x, = ( ),
c
,
< a b c d (A B),
a-b
2H + O 2HO, R = 4.7 k, 200 mm i=1
Linguistics and dictionaries:
i ntnnl fntk sosien
Y [psiln], Yen [jn], Yoga [jog]
APL:
((VV)=V)/V,V
Nicer typography in plain text files:
single and double quotes
Curly apostrophes: Weve been here
Latin-1 apostrophe and accents: '`
deutsche Anfhrungszeichen
, , , , 34, , 5/+5, ,
ASCII safety test: 1lI|, 0OD, 8B
the euro symbol: 14.95
Combining characters:
STARGTE SG-1, a = v = r, a b
Greek (in Polytonic):
The Greek anthem:
,
.
, , !
From a speech of Demosthenes in the 4th century BC:
, ,
,
,
.
, ,
. ,
, ,
,
. ,
,
.
,
Georgian:
From a Unicode conference invitation:
Unicode-
, 10-12 ,
. , .
Unicode-,
, Unicode-
, , ,
.
Russian:
From a Unicode conference invitation:
Unicode, 10-12 1997 .
Unicode, ,
Unicode
, , .
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
Runes:
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz
Greetings in various languages:
Hello world, ,
Box drawing alignment tests:

43
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/benchmarks.lisp Normal file
View file

@ -0,0 +1,43 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; benchmarks.lisp --- Benchmarks, Babel vs. other implementations.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(defpackage #:babel-benchmarks
(:use #:cl #:babel))
(in-package #:babel-benchmarks)
(defun benchmark (enc file-name file-type &optional (n 100))
(let* ((octets (read-test-file file-name file-type))
(string (octets-to-string octets :encoding enc)))
(write-line ";; testing SB-EXT:STRING-TO-OCTETS")
(time (loop repeat n do
(sb-ext:string-to-octets string :external-format enc)))
(write-line ";; testing BABEL:STRING-TO-OCTETS")
(time (loop repeat n do (string-to-octets string :encoding enc)))
(write-line ";; testing SB-EXT:OCTETS-TO-STRING")
(time (loop repeat n do
(sb-ext:octets-to-string octets :external-format enc)))
(write-line ";; testing BABEL:OCTETS-TO-STRING")
(time (loop repeat n do (octets-to-string octets :encoding enc)))))

1
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/ebcdic-us.txt Normal file
View file

@ -0,0 +1 @@
%蒹ﾆ`<60><>ヶуА｢＃欄<EFBC83>欄♂描｣<E68F8F>｣@<40>套%%%ﾔ☆彫｢@ﾒ､<EFBE92>@煤弔@彫鼻L哀｣陽aaｦｦｦKンKメ葱＜K､誕｡這梯<E98099>n@@<40><>`<60>`<60>%%%繹<>ﾁ篥ﾉﾉ@ヶ迫▲奄套@蒹ﾆ`<60><>ヶч芙@､｢<EFBDA4>@鴛@｣<>｢@欄♂描｣<E68F8F>｣@<40>套%欧@у<>腐А鴛@苺宴埋<E5AEB4>@ﾉ籔@<40><><EFBFBD><EFBFBD>@＆Аﾙﾆﾃ@<40><>K%%%茲鴛①苺宴埋<E5AEB4>蒹ﾆ`<60>@ｨ巳@メ鼻ｦ刮｣<E588AE>鴛@<40>♂討@＆А｢巳刄<E5B7B3>ヶу@｣<>芙｢@｢､ヨ@△%%ﾔ▲<EFBE94>煤｣宴｢@＆А｢ラ<EFBDA2>ュ｢z%%@@@ﾅп@~@ﾘk@@鼻@k@@<40>云@~@@⑭云k@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@¨<>%@@ｧz@ｧ@~@ｧk@@@_@~@_M_@@]k@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ァ@@%@@@@@@@@@@@@k@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@L@　@<40>@ァ@А@@@Mﾁ@@ﾂ]k@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@～<>%@@<40>@N@ﾖ@@<40>ﾖk@ﾙ@~@<40><>談@@<40><>粕@@@@@円<>@@@%%ﾓ鴛<EFBE93>欧｣宴｢@＆АчΕ塩普刮<E699AE>z%%@@院淵封邸<E5B081>｣叩｢未怨<E69CAA>%@@錙里遠斌@閻鼻装k@阮〟@走<>%%ﾁﾗﾓz%%@@MM裹]~蘊a虧蕁@@@%%ﾕ宴<EFBE95>@｣ｨ蘭⊿＠葵@鴛@欄♂鼻｣<E9BCBB>｣@<40>套｢z%%@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@｢鴛∮<E9B49B>＆А<EFBC86>､ｓ<EFBDA4>丶魅<E4B8B6>@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@ﾃ､剴ｨ@＠未｣剿来<E589BF>z@諷･<E8ABB7>ｅ<EFBFBD>@<40>刔@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@ﾓ▲鴛`<60>＠未｣剿来<E589BF>＆А＜ュ淵｢z@}y@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@у､｣｢ヨ<EFBDA2>ﾁ膚<EFBE81>､芙｢ｩ<EFBDA2>ヨ<EFBFBD>@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@k@k@k@k@<40>k@k@<40>N<EFBFBD>@k@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@ﾁ篥ﾉﾉ@｢≧<EFBDA2>ｨ@｣<>｣z@<40>ﾉOk@<40>ﾄk@<40>@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@｣<>@<40>剿@｢ｨ狽俣z@@<40>K<EFBFBD>@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@%%ﾃ又ｉ負芙@ヨ☆＜｣<EFBC9C>｢z%%@@粤ﾁﾙﾇ翡@簓`<60>@　~@･@~@冖@　@<40>%%ﾇ刔<EFBE87>@M鴛@ﾗ俣ｨ｣抹宴]z%%@@繹<>ﾇ刔<EFBE87>@＆｣<EFBC86>配%%@@@@@@%@@@@@k%@@@@@@%@@@@@@@K%%@@@@@%@@@@@%@@@@@%@@k@@k@Z%%@@ﾆ剿如　｢羅<EFBDA2><E7BE85>昧@ﾄ<>未｣<E69CAA>腐｢@鴛@｣<>@<40><>ュ淵､勣@ﾂﾃz%%@@@@@@k@@@k%@@@@@@@@@@@%@@@@@@@@@@%@@@@@k@@@%@@@@k@@@@@@%@@@@@K@@@@@%@@@@@@@@k@@@k%@@@@@@@K@@k@@%@@@@@@@@@@@@%@@k@@@@@@@k@@%@@@@@@@@@%@@@@@@k@@@%@@K@@@@@k@@@@%@@@@@@@@@@@%@@@@@k@@@@%@@@@@K%%@@k@@%%ﾇ<>刧堰布%%@@ﾆ剿如　苺宴埋<E5AEB4>ヶ膚<E383B6><E8869A>ュ@鴛･殴▲塩布%%@@@@@@苺宴埋<E5AEB4>@@%@@@k@@@<40>`<60>@k%@@K@k@K@@@@%@@@@@@@@苺宴埋<E5AEB4>k%@@@@k@苺宴埋<E5AEB4>@%@@@k@@@k@k%@@@@@@@K%%ﾙ､｢｢堰布%%@@ﾆ剿如　苺宴埋<E5AEB4>ヶ膚<E383B6><E8869A>ュ@鴛･殴▲塩布%%@@@@@@@@%@@苺宴埋<E5AEB4>@@@<40>`<60>@@<40><>@@@@@K%@@@@@@@@@@%@@@@苺宴埋<E5AEB4>@@@k@@%@@@苺宴埋<E5AEB4>@@@@@%@@k@k@@@@@K%%繹♂@M菘磧ﾓ<E7A3A7><EFBE93>@<40>z%%@@ﾅｧュ剽｣@<40>又@　蘭<E38080>勣@抹@繹<>ﾙ又＆ュ@昧@繹<>繹刔<E7B9B9>ﾒ鴛℡又｢@M　ﾃ<E38080>腐｢<E88590>%@@ン△｢宴@}竅鼻ﾇ､±]z%%@@````````````````````````````O````````````````````````%@@@@@@@%@@@@@@@@@%@@@@@@@@@@@@@@@%@@@@@@@@@@@%@@@@@@@@@@%@@@@@@@@@@@@%@@@@@@@@@@@@@@%@@@@@@@@@@@@@@%%@@M繹<4D>≠箕<E289A0>欧@　｣ｦ冒ヶ豆舶@｣<>｣K@ﾉ<>ヶ狽鴛鴛①ヨ☆＜｣<EFBC9C>｢@☆<><E29886>符套<E7ACA6>%@@ヶ劔<E383B6>｣鐙k@｣<>@悼腐｢@昧@｣<>@｢<>抹Аヶ豆舶@｢<>､塘@ｅ@％援腐Аｦ殴<EFBDA6>｣<EFBFBD>%@@O@ヨ☆＜｣<EFBC9C>@≠箕<E289A0>]%%ﾅ｣<EFBE85>沫堰布%%@@ﾗ剿･<E589BF>い@鴛@｣<>@ﾁ蝿☆宴@刀芙､∞<EFBDA4>%%@@@@@%@@@@@%@@@@@%@@@@@@@%@@@@@%@@@@@%@@@%@@@@@@%@@@@@%@@@@@@@%@@@@@@%@@@@@@@%@@@@@%@@@@@@@%@@@@@@@%@@@@@%@@@@@@%@@@@@%%ﾙ､腐｢z%%@@@@@@@@@@@@@%%@@Mﾖ塘@ﾅ芙悼｢<E682BC>@ｦ<>ヨ@｣凵覆<E587B5>奄<EFBFBD>@鴛｣法ﾓ▲鴛@刔＞｢@}ﾈ<>Θ≦｣<E289A6>｣<EFBFBD>｣@<40>%@@うу@｣<><EFBDA3>@刀符<E58880>楓劵姶<E58AB5>刋､如ｦ殴<EFBDA6>｣<EFBFBD>@諷｢｣｢≦K}@＆А賠＆｢@}ﾈ<>｢♂<EFBDA2>%@@｣<>｣@<40>@悼･<E682BC>@鴛@｣<>@楓劵<E6A593>剳@刀符@腐☆@｣<>@諷｢｣<EFBDA2>鼻竇゜}]%%ﾂ凵遠套z%%@@@@@@%%@@@@@@@@@@@%@@@@@@@@@@%@@@@@@@@@%@@@@@@@@@%@@@@@@@@@@%@@@@@@@%%@@@@@@@@@%%@@@@@@@@@@@@%@@@@@@@@@%@@@@@@@@@@%@@@@@@@@@@%@@@@@@@@@@%@@@@@@@@@%@@@@@@@@@@@%@@@@@@@@@%@@@@@@@@%%@@M繹<4D><E7B9B9>劼｣@ヶ､欄<EFBDA4>昧@浴凵⊿＠阿@昧@ﾁ@ﾃ<>欧｣煤｢@ﾃ☆俣@お@ﾄ宴着覆]%%ﾃ又浴Ε@<40>淵@｢<><EFBDA2>｣塩鼻<E5A1A9>＃欄<EFBC83>｣<EFBFBD>｣z%%@@ﾁﾂﾃﾄﾅﾆﾇﾈﾉﾑﾒﾓﾔﾕﾖﾗﾘﾙ粤蒟跚韜@a<><61><EFBFBD><EFBFBD><EFBFBD>%@@≠ヤ<E289A0>㊧苑駐舶沫<E888B6>｢｣､･ｦｧｨｩ@%@@@@%@@@@@%%ﾇ刔<EFBE87>鴛<EFBFBD>@鴛@･☆塩､｢@刀芙､∞<EFBDA4>z%%@@ﾈ<>当@ｦ侭塘k@@k@%%ﾂ密@<40>※鴛①％援部<E68FB4>｣@｣<>｣｢z@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@%@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@%

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/ebcdic-us.txt-utf8 Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
Markus Kuhn maks kun <http://www.cl.cam.ac.uk/~mgk25/> 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
Eda = Q, n , f(i) = g(i),
a+b
x: x = x, ¬ = ¬(¬ ),
c
,
< a b c d (A B),
a-b
2H + O 2HO, R = 4.7 k, 200 mm i=1
Linguistics and dictionaries:
i ntnnl fntk sosien
Y psiln, Yen jn, Yoga jog
APL:
((VV)=V)/V,V
Nicer typography in plain text files:
single and double quotes
Curly apostrophes: Weve been here
Latin-1 apostrophe and accents: '`
deutsche Anfhrungszeichen
, , , , 34, , 5/+5, ,
ASCII safety test: 1lI|, 0OD, 8B
the euro symbol: 14.95
Combining characters:
STARGTE SG-1, a = v = r, a b
Greek (in Polytonic):
The Greek anthem:
,
.
, , !
From a speech of Demosthenes in the 4th century BC:
, ,
,
,
.
, ,
. ,
, ,
,
. ,
,
.
,
Georgian:
From a Unicode conference invitation:
Unicode-
, 10-12 ,
. , .
Unicode-,
, Unicode-
, , ,
.
Russian:
From a Unicode conference invitation:
Unicode, 10-12 1997 .
Unicode, ,
Unicode
, , .
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
----------------------------|------------------------
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
Runes:
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz
Greetings in various languages:
Hello world, ,
Box drawing alignment tests:

37
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/gen-test-files.sh Normal file
View file

@ -0,0 +1,37 @@
#!/bin/sh
# -*- indent-tabs-mode: nil -*-
#
# gen-test-files.sh --- Generates test files with iconv.
#
# Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
INPUT_FILE="utf-8.txt"
INPUT_ENC="utf-8"
CHARSETS=('ebcdic-us' 'ascii' 'iso-8859-1' 'utf-16' 'utf-32')
echo "Converting $INPUT_FILE..."
for c in ${CHARSETS[@]}; do
echo " ${c}.txt";
iconv -c -f $INPUT_ENC -t $c $INPUT_FILE > ${c}.txt;
iconv -f $c -t 'utf-8' ${c}.txt > ${c}.txt-utf8;
done

45
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/streams.lisp Normal file
View file

@ -0,0 +1,45 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; streams.lisp --- Unit and regression tests for Babel streams.
;;;
;;; Copyright (C) 2007, Attila Lendva <attila.lendvai@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-tests)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :babel-streams))
(deftest in-memory-vector-stream
(with-output-to-sequence (output)
;; TODO use a better test lib and inject asserts for the file position
;(print (file-position output))
(write-sequence "éáőűú" output)
;(print (file-position output))
(write-char #\ű output)
;(print (file-position output))
(write-byte 12 output)
(write-sequence (string-to-octets "körte") output)
(write-string "körte" output)
;(print (file-position output))
)
#(195 169 195 161 197 145 197 177 195 186 197 177 12 107 195 182 114 116 101))

912
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/tests.lisp Normal file
View file

@ -0,0 +1,912 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; tests.lisp --- Unit and regression tests for Babel.
;;;
;;; Copyright (C) 2007-2009, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:cl-user)
(defpackage #:babel-tests
(:use #:common-lisp #:babel #:babel-encodings #:hu.dwim.stefil)
(:import-from #:alexandria #:ignore-some-conditions)
(:export #:run))
(in-package #:babel-tests)
(defun indented-format (level stream format-control &rest format-arguments)
(let ((line-prefix (make-string level :initial-element #\Space)))
(let ((output (format nil "~?~%" format-control format-arguments)))
(with-input-from-string (s output)
(loop for line = (read-line s nil nil) until (null line)
do (format stream "~A~A~%" line-prefix line))))))
;; adapted from https://github.com/luismbo/stefil/blob/master/source/suite.lisp
(defun describe-failed-tests (&key (result *last-test-result*) (stream t))
"Prints out a report for RESULT in STREAM.
RESULT defaults to `*last-test-result*' and STREAM defaults to t"
(let ((descs (hu.dwim.stefil::failure-descriptions-of result)))
(cond ((zerop (length descs))
(format stream "~&~%[no failures!]"))
(t
(format stream "~&~%Test failures:~%")
(dotimes (i (length descs))
(let ((desc (aref descs i))
format-control format-arguments)
;; XXX: most of Stefil's conditions specialise DESCRIBE-OBJECT
;; with nice human-readable messages. We should add any missing
;; ones (like UNEXPECTED-ERROR) and ditch this code.
(etypecase desc
(hu.dwim.stefil::unexpected-error
(let ((c (hu.dwim.stefil::condition-of desc)))
(typecase c
(simple-condition
(setf format-control (simple-condition-format-control c))
(setf format-arguments
(simple-condition-format-arguments c)))
(t
(setf format-control "~S"
format-arguments (list c))))))
(hu.dwim.stefil::failed-assertion
(setf format-control (hu.dwim.stefil::format-control-of desc)
format-arguments (hu.dwim.stefil::format-arguments-of desc)))
(hu.dwim.stefil::missing-condition
(setf format-control "~A"
format-arguments (list (with-output-to-string (stream)
(describe desc stream)))))
(null
(setf format-control "Test succeeded!")))
(format stream "~%Failure ~A: ~A when running ~S~%~%"
(1+ i)
(type-of desc)
(hu.dwim.stefil::name-of (hu.dwim.stefil::test-of (first (hu.dwim.stefil::test-context-backtrace-of desc)))))
(indented-format 4 stream "~?" format-control format-arguments)))))))
(defun run ()
(let ((test-run (without-debugging (babel-tests))))
(print test-run)
(describe-failed-tests :result test-run)
(values (zerop (length (hu.dwim.stefil::failure-descriptions-of test-run)))
test-run)))
(defsuite* (babel-tests :in root-suite))
(defun ub8v (&rest contents)
(make-array (length contents) :element-type '(unsigned-byte 8)
:initial-contents contents))
(defun make-ub8-vector (size)
(make-array size :element-type '(unsigned-byte 8)
:initial-element 0))
(defmacro returns (form &rest values)
"Asserts, through EQUALP, that FORM returns VALUES."
`(is (equalp (multiple-value-list ,form) (list ,@values))))
(defmacro defstest (name form &body return-values)
"Similar to RT's DEFTEST."
`(deftest ,name ()
(returns ,form ,@(mapcar (lambda (x) `',x) return-values))))
(defun fail (control-string &rest arguments)
(hu.dwim.stefil::record/failure 'hu.dwim.stefil::failed-assertion
:format-control control-string
:format-arguments arguments))
(defun expected (expected &key got)
(fail "expected ~A, got ~A instead" expected got))
(enable-sharp-backslash-syntax)
;;;; Simple tests using ASCII
(defstest enc.ascii.1
(string-to-octets "abc" :encoding :ascii)
#(97 98 99))
(defstest enc.ascii.2
(string-to-octets (string #\uED) :encoding :ascii :errorp nil)
#(#x1a))
(deftest enc.ascii.3 ()
(handler-case
(string-to-octets (string #\uED) :encoding :ascii :errorp t)
(character-encoding-error (c)
(is (eql 0 (character-coding-error-position c)))
(is (eq :ascii (character-coding-error-encoding c)))
(is (eql #xed (character-encoding-error-code c))))
(:no-error (result)
(expected 'character-encoding-error :got result))))
(defstest dec.ascii.1
(octets-to-string (ub8v 97 98 99) :encoding :ascii)
"abc")
(deftest dec.ascii.2 ()
(handler-case
(octets-to-string (ub8v 97 128 99) :encoding :ascii :errorp t)
(character-decoding-error (c)
(is (equalp #(128) (character-decoding-error-octets c)))
(is (eql 1 (character-coding-error-position c)))
(is (eq :ascii (character-coding-error-encoding c))))
(:no-error (result)
(expected 'character-decoding-error :got result))))
(defstest dec.ascii.3
(octets-to-string (ub8v 97 255 98 99) :encoding :ascii :errorp nil)
#(#\a #\Sub #\b #\c))
(defstest oct-count.ascii.1
(string-size-in-octets "abc" :encoding :ascii)
3 3)
(defstest char-count.ascii.1
(vector-size-in-chars (ub8v 97 98 99) :encoding :ascii)
3 3)
;;;; UTF-8
(defstest char-count.utf-8.1
;; "ni hao" in hanzi with the last octet missing
(vector-size-in-chars (ub8v 228 189 160 229 165) :errorp nil)
2 5)
(deftest char-count.utf-8.2 ()
;; same as above with the last 2 octets missing
(handler-case
(vector-size-in-chars (ub8v 228 189 160 229) :errorp t)
(end-of-input-in-character (c)
(is (equalp #(229) (character-decoding-error-octets c)))
(is (eql 3 (character-coding-error-position c)))
(is (eq :utf-8 (character-coding-error-encoding c))))
(:no-error (result)
(expected 'end-of-input-in-character :got result))))
;;; Lispworks bug?
;; #+lispworks
;; (pushnew 'dec.utf-8.1 rtest::*expected-failures*)
(defstest dec.utf-8.1
(octets-to-string (ub8v 228 189 160 229) :errorp nil)
#(#\u4f60 #\ufffd))
(deftest dec.utf-8.2 ()
(handler-case
(octets-to-string (ub8v 228 189 160 229) :errorp t)
(end-of-input-in-character (c)
(is (equalp #(229) (character-decoding-error-octets c)))
(is (eql 3 (character-coding-error-position c)))
(is (eq :utf-8 (character-coding-error-encoding c))))
(:no-error (result)
(expected 'end-of-input-in-character :got result))))
;;;; UTF-16
;;; Test that the BOM is not being counted as a character.
(deftest char-count.utf-16.bom ()
(is (eql (vector-size-in-chars (ub8v #xfe #xff #x00 #x55 #x00 #x54 #x00 #x46)
:encoding :utf-16)
3))
(is (eql (vector-size-in-chars (ub8v #xff #xfe #x00 #x55 #x00 #x54 #x00 #x46)
:encoding :utf-16)
3)))
;;;; UTF-32
;;; RT: check that UTF-32 characters without a BOM are treated as
;;; little-endian.
(deftest endianness.utf-32.no-bom ()
(is (string= "a" (octets-to-string (ub8v 0 0 0 97) :encoding :utf-32))))
;;;; MORE TESTS
(defparameter *standard-characters*
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~")
;;; Testing consistency by encoding and decoding a simple string for
;;; all character encodings.
(deftest rw-equiv.1 ()
(let ((compatible-encodings (remove :ebcdic-international (list-character-encodings))))
(dolist (*default-character-encoding* compatible-encodings)
(let ((octets (string-to-octets *standard-characters*)))
(is (string= (octets-to-string octets) *standard-characters*))))))
;;; FIXME: assumes little-endianness. Easily fixable when we
;;; implement the BE and LE variants of :UTF-16.
(deftest concatenate-strings-to-octets-equiv.1 ()
(let ((foo (octets-to-string (ub8v 102 195 186 195 186)
:encoding :utf-8))
(bar (octets-to-string (ub8v 98 195 161 114)
:encoding :utf-8)))
;; note: FOO and BAR are not ascii
(is (equalp (concatenate-strings-to-octets :utf-8 foo bar)
(ub8v 102 195 186 195 186 98 195 161 114)))
(is (equalp (concatenate-strings-to-octets :utf-16 foo bar)
(ub8v 102 0 250 0 250 0 98 0 225 0 114 0)))))
;;;; Testing against files generated by GNU iconv.
(defun test-file (name type)
(uiop:subpathname (asdf:system-relative-pathname "babel-tests" "tests/")
name :type type))
(defun read-test-file (name type)
(with-open-file (in (test-file name type) :element-type '(unsigned-byte 8))
(let* ((data (loop for byte = (read-byte in nil nil)
until (null byte) collect byte)))
(make-array (length data) :element-type '(unsigned-byte 8)
:initial-contents data))))
(deftest test-encoding (enc &optional input-enc-name)
(let* ((*default-character-encoding* enc)
(enc-name (string-downcase (symbol-name enc)))
(utf8-octets (read-test-file enc-name "txt-utf8"))
(foo-octets (read-test-file (or input-enc-name enc-name) "txt"))
(utf8-string (octets-to-string utf8-octets :encoding :utf-8 :errorp t))
(foo-string (octets-to-string foo-octets :errorp t)))
(is (string= utf8-string foo-string))
(is (= (length foo-string) (vector-size-in-chars foo-octets :errorp t)))
(unless (member enc '(:utf-16 :utf-32))
;; FIXME: skipping UTF-16 and UTF-32 because of the BOMs and
;; because the input might not be in native-endian order so the
;; comparison will fail there.
(let ((new-octets (string-to-octets foo-string :errorp t)))
(is (equalp new-octets foo-octets))
(is (eql (length foo-octets)
(string-size-in-octets foo-string :errorp t)))))))
(deftest iconv-test ()
(dolist (enc '(:ascii :ebcdic-us :utf-8 :utf-16 :utf-32))
(case enc
(:utf-16 (test-encoding :utf-16 "utf-16-with-le-bom"))
(:utf-32 (test-encoding :utf-32 "utf-32-with-le-bom")))
(test-encoding enc)))
;;; RT: accept encoding objects in LOOKUP-MAPPING etc.
(defstest encoding-objects.1
(string-to-octets "abc" :encoding (get-character-encoding :ascii))
#(97 98 99))
(defmacro with-sharp-backslash-syntax (&body body)
`(let ((*readtable* (copy-readtable *readtable*)))
(set-sharp-backslash-syntax-in-readtable)
,@body))
(defstest sharp-backslash.1
(with-sharp-backslash-syntax
(loop for string in '("#\\a" "#\\u" "#\\ued")
collect (char-code (read-from-string string))))
(97 117 #xed))
(deftest sharp-backslash.2 ()
(signals reader-error (with-sharp-backslash-syntax
(read-from-string "#\\u12zz"))))
(deftest test-read-from-string (string object position)
"Test that (read-from-string STRING) returns values OBJECT and POSITION."
(multiple-value-bind (obj pos)
(read-from-string string)
(is (eql object obj))
(is (eql position pos))))
;;; RT: our #\ reader didn't honor *READ-SUPPRESS*.
(deftest sharp-backslash.3 ()
(with-sharp-backslash-syntax
(let ((*read-suppress* t))
(test-read-from-string "#\\ujunk" nil 7)
(test-read-from-string "#\\u12zz" nil 7))))
;;; RT: the slow implementation of with-simple-vector was buggy.
(defstest string-to-octets.1
(code-char (aref (string-to-octets "abc" :start 1 :end 2) 0))
#\b)
(defstest simple-base-string.1
(string-to-octets (coerce "abc" 'base-string) :encoding :ascii)
#(97 98 99))
;;; For now, disable this tests for Lisps that are strict about
;;; non-character code points. In the future, simply mark them as
;;; expected failures.
#-(or abcl ccl)
(progn
(defstest utf-8b.1
(string-to-octets (coerce #(#\a #\b #\udcf0) 'unicode-string)
:encoding :utf-8b)
#(97 98 #xf0))
#+#:temporarily-disabled
(defstest utf-8b.2
(octets-to-string (ub8v 97 98 #xcd) :encoding :utf-8b)
#(#\a #\b #\udccd))
(defstest utf-8b.3
(octets-to-string (ub8v 97 #xf0 #xf1 #xff #x01) :encoding :utf-8b)
#(#\a #\udcf0 #\udcf1 #\udcff #\udc01))
(deftest utf-8b.4 ()
(let* ((octets (coerce (loop repeat 8192 collect (random (+ #x82)))
'(array (unsigned-byte 8) (*))))
(string (octets-to-string octets :encoding :utf-8b)))
(is (equalp octets (string-to-octets string :encoding :utf-8b))))))
;;; The following tests have been adapted from SBCL's
;;; tests/octets.pure.lisp file.
(deftest ensure-roundtrip-ascii ()
(let ((octets (make-ub8-vector 128)))
(dotimes (i 128)
(setf (aref octets i) i))
(let* ((str (octets-to-string octets :encoding :ascii))
(oct2 (string-to-octets str :encoding :ascii)))
(is (= (length octets) (length oct2)))
(is (every #'= octets oct2)))))
(deftest test-8bit-roundtrip (enc)
(let ((octets (make-ub8-vector 256)))
(dotimes (i 256)
(setf (aref octets i) i))
(let* ((str (octets-to-string octets :encoding enc)))
;; remove the undefined code-points because they translate
;; to #xFFFD and string-to-octets raises an error when
;; encoding #xFFFD
(multiple-value-bind (filtered-str filtered-octets)
(let ((s (make-array 0 :element-type 'character
:adjustable t :fill-pointer 0))
(o (make-array 0 :element-type '(unsigned-byte 16)
:adjustable t :fill-pointer 0)))
(loop for i below 256
for c = (aref str i)
when (/= (char-code c) #xFFFD)
do (vector-push-extend c s)
(vector-push-extend (aref octets i) o))
(values s o))
(let ((oct2 (string-to-octets filtered-str :encoding enc)))
(is (eql (length filtered-octets) (length oct2)))
(is (every #'eql filtered-octets oct2)))))))
(defparameter *iso-8859-charsets*
'(:iso-8859-1 :iso-8859-2 :iso-8859-3 :iso-8859-4 :iso-8859-5 :iso-8859-6
:iso-8859-7 :iso-8859-8 :iso-8859-9 :iso-8859-10 :iso-8859-11 :iso-8859-13
:iso-8859-14 :iso-8859-15 :iso-8859-16))
;;; Don't actually see what comes out, but there shouldn't be any
;;; errors.
(deftest iso-8859-roundtrip-no-checking ()
(loop for enc in *iso-8859-charsets* do (test-8bit-roundtrip enc)))
(deftest ensure-roundtrip-latin ()
(loop for enc in '(:latin1 :latin9) do (test-8bit-roundtrip enc)))
;;; Latin-9 chars; the previous test checked roundtrip from
;;; octets->char and back, now test that the latin-9 characters did in
;;; fact appear during that trip.
(deftest ensure-roundtrip-latin9 ()
(let ((l9c (map 'string #'code-char '(8364 352 353 381 382 338 339 376))))
(is (string= (octets-to-string (string-to-octets l9c :encoding :latin9)
:encoding :latin9)
l9c))))
;; Expected to fail on Lisps that are strict about non-character code
;; points. Mark this as an expected failure when Stefil supports such
;; a feature.
#-(or abcl ccl)
(deftest code-char-nilness ()
(is (loop for i below unicode-char-code-limit
never (null (code-char i)))))
(deftest test-unicode-roundtrip (enc)
(let ((string (make-string unicode-char-code-limit)))
(dotimes (i unicode-char-code-limit)
(setf (char string i)
(if (or (<= #xD800 i #xDFFF)
(<= #xFDD0 i #xFDEF)
(eql (logand i #xFFFF) #xFFFF)
(eql (logand i #xFFFF) #xFFFE))
#\? ; don't try to encode non-characters.
(code-char i))))
(let ((string2 (octets-to-string
(string-to-octets string :encoding enc :errorp t)
:encoding enc :errorp t)))
(is (eql (length string2) (length string)))
(is (string= string string2)))))
(deftest ensure-roundtrip.utf8 ()
(test-unicode-roundtrip :utf-8))
(deftest ensure-roundtrip.utf16 ()
(test-unicode-roundtrip :utf-16))
(deftest ensure-roundtrip.utf32 ()
(test-unicode-roundtrip :utf-32))
#+sbcl
(progn
(deftest test-encode-against-sbcl (enc)
(let ((string (make-string unicode-char-code-limit)))
(dotimes (i unicode-char-code-limit)
(setf (char string i) (code-char i)))
(loop for ch across string
for babel = (string-to-octets (string ch) :encoding enc)
for sbcl = (sb-ext:string-to-octets (string ch)
:external-format enc)
do (is (equalp babel sbcl)))))
;; not run automatically because it's a bit slow (1114112 assertions)
(deftest (test-encode-against-sbcl.utf-8 :auto-call nil) ()
(test-encode-against-sbcl :utf-8)))
(deftest non-ascii-bytes ()
(let ((octets (make-array 128
:element-type '(unsigned-byte 8)
:initial-contents (loop for i from 128 below 256
collect i))))
(is (string= (octets-to-string octets :encoding :ascii :errorp nil)
(make-string 128 :initial-element #\Sub)))))
(deftest non-ascii-chars ()
(let ((string (make-array 128
:element-type 'character
:initial-contents (loop for i from 128 below 256
collect (code-char i)))))
(is (equalp (string-to-octets string :encoding :ascii :errorp nil)
(make-array 128 :initial-element (char-code #\Sub))))))
;;;; The following UTF-8 decoding tests are adapted from
;;;; <http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt>.
(deftest utf8-decode-test (octets expected-results expected-errors)
(let ((string (octets-to-string (coerce octets '(vector (unsigned-byte 8) *))
:encoding :utf-8 :errorp nil)))
(is (string= expected-results string))
(is (= (count #\ufffd string) expected-errors))))
(deftest utf8-decode-tests (octets expected-results)
(setf expected-results (coerce expected-results '(simple-array character (*))))
(let ((expected-errors (count #\? expected-results))
(expected-results (substitute #\ufffd #\? expected-results)))
(utf8-decode-test octets expected-results expected-errors)
(utf8-decode-test (concatenate 'vector '(34) octets '(34))
(format nil "\"~A\"" expected-results)
expected-errors)))
(deftest utf8-too-big-characters ()
(utf8-decode-tests #(#xf4 #x90 #x80 #x80) "?") ; #x110000
(utf8-decode-tests #(#xf7 #xbf #xbf #xbf) "?") ; #x1fffff
(utf8-decode-tests #(#xf8 #x88 #x80 #x80 #x80) "?") ; #x200000
(utf8-decode-tests #(#xfb #xbf #xbf #xbf #xbf) "?") ; #x3ffffff
(utf8-decode-tests #(#xfc #x84 #x80 #x80 #x80 #x80) "?") ; #x4000000e
(utf8-decode-tests #(#xfd #xbf #xbf #xbf #xbf #xbf) "?")) ; #x7fffffff
(deftest utf8-unexpected-continuation-bytes ()
(utf8-decode-tests #(#x80) "?")
(utf8-decode-tests #(#xbf) "?")
(utf8-decode-tests #(#x80 #xbf) "??")
(utf8-decode-tests #(#x80 #xbf #x80) "???")
(utf8-decode-tests #(#x80 #xbf #x80 #xbf) "????")
(utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80) "?????")
(utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80 #xbf) "??????")
(utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80 #xbf #x80) "???????"))
;;; All 64 continuation bytes in a row.
(deftest utf8-continuation-bytes ()
(apply #'utf8-decode-tests
(loop for i from #x80 to #xbf
collect i into bytes
collect #\? into chars
finally (return (list bytes
(coerce chars 'string))))))
(deftest utf8-lonely-start-characters ()
(flet ((lsc (first last)
(apply #'utf8-decode-tests
(loop for i from first to last
nconc (list i 32) into bytes
nconc (list #\? #\Space) into chars
finally (return (list bytes (coerce chars 'string)))))
(apply #'utf8-decode-tests
(loop for i from first to last
collect i into bytes
collect #\? into chars
finally (return
(list bytes (coerce chars 'string)))))))
(lsc #xc0 #xdf) ; 2-byte sequence start chars
(lsc #xe0 #xef) ; 3-byte
(lsc #xf0 #xf7) ; 4-byte
(lsc #xf8 #xfb) ; 5-byte
(lsc #xfc #xfd))) ; 6-byte
;;; Otherwise incomplete sequences (last continuation byte missing)
(deftest utf8-incomplete-sequences ()
(utf8-decode-tests #0=#(#xc0) "?")
(utf8-decode-tests #1=#(#xe0 #x80) "?")
(utf8-decode-tests #2=#(#xf0 #x80 #x80) "?")
(utf8-decode-tests #3=#(#xf8 #x80 #x80 #x80) "?")
(utf8-decode-tests #4=#(#xfc #x80 #x80 #x80 #x80) "?")
(utf8-decode-tests #5=#(#xdf) "?")
(utf8-decode-tests #6=#(#xef #xbf) "?")
(utf8-decode-tests #7=#(#xf7 #xbf #xbf) "?")
(utf8-decode-tests #8=#(#xfb #xbf #xbf #xbf) "?")
(utf8-decode-tests #9=#(#xfd #xbf #xbf #xbf #xbf) "?")
;; All ten previous tests concatenated
(utf8-decode-tests (concatenate 'vector
#0# #1# #2# #3# #4# #5# #6# #7# #8# #9#)
"??????????"))
(deftest utf8-random-impossible-bytes ()
(utf8-decode-tests #(#xfe) "?")
(utf8-decode-tests #(#xff) "?")
(utf8-decode-tests #(#xfe #xfe #xff #xff) "????"))
(deftest utf8-overlong-sequences-/ ()
(utf8-decode-tests #(#xc0 #xaf) "?")
(utf8-decode-tests #(#xe0 #x80 #xaf) "?")
(utf8-decode-tests #(#xf0 #x80 #x80 #xaf) "?")
(utf8-decode-tests #(#xf8 #x80 #x80 #x80 #xaf) "?")
(utf8-decode-tests #(#xfc #x80 #x80 #x80 #x80 #xaf) "?"))
(deftest utf8-overlong-sequences-rubout ()
(utf8-decode-tests #(#xc1 #xbf) "?")
(utf8-decode-tests #(#xe0 #x9f #xbf) "?")
(utf8-decode-tests #(#xf0 #x8f #xbf #xbf) "?")
(utf8-decode-tests #(#xf8 #x87 #xbf #xbf #xbf) "?")
(utf8-decode-tests #(#xfc #x83 #xbf #xbf #xbf #xbf) "?"))
(deftest utf8-overlong-sequences-null ()
(utf8-decode-tests #(#xc0 #x80) "?")
(utf8-decode-tests #(#xe0 #x80 #x80) "?")
(utf8-decode-tests #(#xf0 #x80 #x80 #x80) "?")
(utf8-decode-tests #(#xf8 #x80 #x80 #x80 #x80) "?")
(utf8-decode-tests #(#xfc #x80 #x80 #x80 #x80 #x80) "?"))
;;;; End of adapted SBCL tests.
;;; Expected to fail, for now.
#+#:ignore
(deftest utf8-illegal-code-positions ()
;; single UTF-16 surrogates
(utf8-decode-tests #(#xed #xa0 #x80) "?")
(utf8-decode-tests #(#xed #xad #xbf) "?")
(utf8-decode-tests #(#xed #xae #x80) "?")
(utf8-decode-tests #(#xed #xaf #xbf) "?")
(utf8-decode-tests #(#xed #xb0 #x80) "?")
(utf8-decode-tests #(#xed #xbe #x80) "?")
(utf8-decode-tests #(#xed #xbf #xbf) "?")
;; paired UTF-16 surrogates
(utf8-decode-tests #(ed a0 80 ed b0 80) "??")
(utf8-decode-tests #(ed a0 80 ed bf bf) "??")
(utf8-decode-tests #(ed ad bf ed b0 80) "??")
(utf8-decode-tests #(ed ad bf ed bf bf) "??")
(utf8-decode-tests #(ed ae 80 ed b0 80) "??")
(utf8-decode-tests #(ed ae 80 ed bf bf) "??")
(utf8-decode-tests #(ed af bf ed b0 80) "??")
(utf8-decode-tests #(ed af bf ed bf bf) "??")
;; other illegal code positions
(utf8-decode-tests #(#xef #xbf #xbe) "?") ; #\uFFFE
(utf8-decode-tests #(#xef #xbf #xbf) "?")) ; #\uFFFF
;;; A list of the ISO-8859 encodings where each element is a cons with
;;; the car being a keyword denoting the encoding and the cdr being a
;;; vector enumerating the corresponding character codes.
;;;
;;; It was auto-generated from files which can be found at
;;; <ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/>.
;;;
;;; Taken from flexi-streams.
(defparameter *iso-8859-tables*
'((:iso-8859-1 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
243 244 245 246 247 248 249 250 251 252 253 254 255))
(:iso-8859-2 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 260 728 321 164 317 346 167 168 352 350
356 377 173 381 379 176 261 731 322 180 318 347 711 184 353 351 357 378
733 382 380 340 193 194 258 196 313 262 199 268 201 280 203 282 205 206
270 272 323 327 211 212 336 214 215 344 366 218 368 220 221 354 223 341
225 226 259 228 314 263 231 269 233 281 235 283 237 238 271 273 324 328
243 244 337 246 247 345 367 250 369 252 253 355 729))
(:iso-8859-3 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 294 728 163 164 65533 292 167 168 304
350 286 308 173 65533 379 176 295 178 179 180 181 293 183 184 305 351
287 309 189 65533 380 192 193 194 65533 196 266 264 199 200 201 202 203
204 205 206 207 65533 209 210 211 212 288 214 215 284 217 218 219 220
364 348 223 224 225 226 65533 228 267 265 231 232 233 234 235 236 237
238 239 65533 241 242 243 244 289 246 247 285 249 250 251 252 365 349
729))
(:iso-8859-4 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 260 312 342 164 296 315 167 168 352 274
290 358 173 381 175 176 261 731 343 180 297 316 711 184 353 275 291 359
330 382 331 256 193 194 195 196 197 198 302 268 201 280 203 278 205 206
298 272 325 332 310 212 213 214 215 216 370 218 219 220 360 362 223 257
225 226 227 228 229 230 303 269 233 281 235 279 237 238 299 273 326 333
311 244 245 246 247 248 371 250 251 252 361 363 729))
(:iso-8859-5 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 1025 1026 1027 1028 1029 1030 1031 1032
1033 1034 1035 1036 173 1038 1039 1040 1041 1042 1043 1044 1045 1046
1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060
1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074
1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088
1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102
1103 8470 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116
167 1118 1119))
(:iso-8859-6 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 65533 65533 65533 164 65533 65533 65533
65533 65533 65533 65533 1548 173 65533 65533 65533 65533 65533 65533
65533 65533 65533 65533 65533 65533 65533 1563 65533 65533 65533 1567
65533 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581
1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 65533
65533 65533 65533 65533 1600 1601 1602 1603 1604 1605 1606 1607 1608
1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 65533 65533 65533
65533 65533 65533 65533 65533 65533 65533 65533 65533 65533))
(:iso-8859-7 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 8216 8217 163 8364 8367 166 167 168 169
890 171 172 173 65533 8213 176 177 178 179 900 901 902 183 904 905 906
187 908 189 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924
925 926 927 928 929 65533 931 932 933 934 935 936 937 938 939 940 941
942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959
960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 65533))
(:iso-8859-8 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 65533 162 163 164 165 166 167 168 169
215 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 247 187
188 189 190 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533
65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 65533
65533 65533 65533 65533 65533 65533 65533 65533 65533 65533 8215 1488
1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502
1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 65533 65533
8206 8207 65533))
(:iso-8859-9 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
207 286 209 210 211 212 213 214 215 216 217 218 219 220 304 350 223 224
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 287 241 242
243 244 245 246 247 248 249 250 251 252 305 351 255))
(:iso-8859-10 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 260 274 290 298 296 310 167 315 272 352
358 381 173 362 330 176 261 275 291 299 297 311 183 316 273 353 359 382
8213 363 331 256 193 194 195 196 197 198 302 268 201 280 203 278 205 206
207 208 325 332 211 212 213 214 360 216 370 218 219 220 221 222 223 257
225 226 227 228 229 230 303 269 233 281 235 279 237 238 239 240 326 333
243 244 245 246 361 248 371 250 251 252 253 254 312))
(:iso-8859-11 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 3585 3586 3587 3588 3589 3590 3591 3592
3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606
3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620
3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634
3635 3636 3637 3638 3639 3640 3641 3642 65533 65533 65533 65533 3647
3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661
3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675
65533 65533 65533 65533))
(:iso-8859-13 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 8221 162 163 164 8222 166 167 216 169
342 171 172 173 174 198 176 177 178 179 8220 181 182 183 248 185 343 187
188 189 190 230 260 302 256 262 196 197 280 274 268 201 377 278 290 310
298 315 352 323 325 211 332 213 214 215 370 321 346 362 220 379 381 223
261 303 257 263 228 229 281 275 269 233 378 279 291 311 299 316 353 324
326 243 333 245 246 247 371 322 347 363 252 380 382 8217))
(:iso-8859-14 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 7682 7683 163 266 267 7690 167 7808 169
7810 7691 7922 173 174 376 7710 7711 288 289 7744 7745 182 7766 7809
7767 7811 7776 7923 7812 7813 7777 192 193 194 195 196 197 198 199 200
201 202 203 204 205 206 207 372 209 210 211 212 213 214 7786 216 217 218
219 220 221 374 223 224 225 226 227 228 229 230 231 232 233 234 235 236
237 238 239 373 241 242 243 244 245 246 7787 248 249 250 251 252 253 375
255))
(:iso-8859-15 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 161 162 163 8364 165 352 167 353 169 170
171 172 173 174 175 176 177 178 179 381 181 182 183 382 185 186 187 338
339 376 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
243 244 245 246 247 248 249 250 251 252 253 254 255))
(:iso-8859-16 .
#(0 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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
153 154 155 156 157 158 159 160 260 261 321 8364 8222 352 167 353 169
536 171 377 173 378 379 176 177 268 322 381 8221 182 183 382 269 537 187
338 339 376 380 192 193 194 258 196 262 198 199 200 201 202 203 204 205
206 207 272 323 210 211 212 336 214 346 368 217 218 219 220 280 538 223
224 225 226 259 228 263 230 231 232 233 234 235 236 237 238 239 273 324
242 243 244 337 246 347 369 249 250 251 252 281 539 255))))
(deftest iso-8859-decode-check ()
(loop for enc in *iso-8859-charsets*
for octets = (let ((octets (make-ub8-vector 256)))
(dotimes (i 256 octets)
(setf (aref octets i) i)))
for string = (octets-to-string octets :encoding enc)
do (is (equalp (map 'vector #'char-code string)
(cdr (assoc enc *iso-8859-tables*))))))
(deftest character-out-of-range.utf-32 ()
(signals character-out-of-range
(octets-to-string (ub8v 0 0 #xfe #xff 0 #x11 0 0)
:encoding :utf-32 :errorp t)))
;;; RT: encoders and decoders were returning bogus values.
(deftest encoder/decoder-retvals (encoding &optional (test-string (coerce "abc" '(simple-array character (*)))))
(let* ((mapping (lookup-mapping babel::*string-vector-mappings* encoding))
(strlen (length test-string))
;; encoding
(octet-precount (funcall (octet-counter mapping)
test-string 0 strlen -1))
(array (make-array octet-precount :element-type '(unsigned-byte 8)))
(encoded-octet-count (funcall (encoder mapping)
test-string 0 strlen array 0))
;; decoding
(string (make-string strlen))
(char-precount (funcall (code-point-counter mapping)
array 0 octet-precount -1))
(char-count (funcall (decoder mapping)
array 0 octet-precount string 0)))
(is (= octet-precount encoded-octet-count))
(is (= char-precount char-count))
(is (string= test-string string))))
(deftest encoder-and-decoder-return-values ()
(mapcar 'encoder/decoder-retvals
(remove-if 'ambiguous-encoding-p
(list-character-encodings))))
(deftest code-point-sweep (encoding)
(finishes
(dotimes (i char-code-limit)
(let ((char (ignore-errors (code-char i))))
(when char
(ignore-some-conditions (character-encoding-error)
(string-to-octets (string char) :encoding encoding)))))))
#+enable-slow-babel-tests
(deftest code-point-sweep-all-encodings ()
(mapc #'code-point-sweep (list-character-encodings)))
(deftest octet-sweep (encoding)
(finishes
(loop for b1 upto #xff do
(loop for b2 upto #xff do
(loop for b3 upto #xff do
(loop for b4 upto #xff do
(ignore-some-conditions (character-decoding-error)
(octets-to-string (ub8v b1 b2 b3 b4) :encoding encoding))))))))
#+enable-slow-babel-tests
(deftest octet-sweep-all-encodings ()
(mapc #'octet-sweep (list-character-encodings)))

BIN
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-16-with-le-bom.txt Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-16.txt Normal file
View file

Binary file not shown.

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-16.txt-utf8 Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫
⎪⎢⎜│a²+b³ ⎟⎥⎪
∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪
⎪⎢⎜⎷ c₈ ⎟⎥⎪
ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬
⎪⎢⎜ ∞ ⎟⎥⎪
⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪
⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭
Linguistics and dictionaries:
ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
APL:
((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
Nicer typography in plain text files:
╔══════════════════════════════════════════╗
║ ║
║ • ‘single’ and “double” quotes ║
║ ║
║ • Curly apostrophes: “We’ve been here” ║
║ ║
║ • Latin-1 apostrophe and accents: '´` ║
║ ║
║ • ‚deutsche‘ „Anführungszeichen“ ║
║ ║
║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
║ ║
║ • ASCII safety test: 1lI|, 0OD, 8B ║
║ ╭─────────╮ ║
║ • the euro symbol: │ 14.95 € │ ║
║ ╰─────────╯ ║
╚══════════════════════════════════════════╝
Combining characters:
STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑
Greek (in Polytonic):
The Greek anthem:
Σὲ γνωρίζω ἀπὸ τὴν κόψη
τοῦ σπαθιοῦ τὴν τρομερή,
σὲ γνωρίζω ἀπὸ τὴν ὄψη
ποὺ μὲ βία μετράει τὴ γῆ.
᾿Απ᾿ τὰ κόκκαλα βγαλμένη
τῶν ῾Ελλήνων τὰ ἱερά
καὶ σὰν πρῶτα ἀνδρειωμένη
χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
From a speech of Demosthenes in the 4th century BC:
Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
Georgian:
From a Unicode conference invitation:
გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
Russian:
From a Unicode conference invitation:
Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
Конференция соберет широкий круг экспертов по вопросам глобального
Интернета и Unicode, локализации и интернационализации, воплощению и
применению Unicode в различных операционных системах и программных
приложениях, шрифтах, верстке и многоязычных компьютерных системах.
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
ሰማይ አይታረስ ንጉሥ አይከሰስ።
ብላ ካለኝ እንደአባቴ በቆመጠኝ።
ጌጥ ያለቤቱ ቁምጥና ነው።
ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
የአፍ ወለምታ በቅቤ አይታሽም።
አይጥ በበላ ዳዋ ተመታ።
ሲተረጉሙ ይደረግሙ።
ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
ድር ቢያብር አንበሳ ያስር።
ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
ሥራ ከመፍታት ልጄን ላፋታት።
ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
ተንጋሎ ቢተፉ ተመልሶ ባፉ።
ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
እግርህን በፍራሽህ ልክ ዘርጋ።
Runes:
ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
–—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi<>⑀₂ἠḂӥẄɐː⍎אԱა
Greetings in various languages:
Hello world, Καλημέρα κόσμε, コンニチハ
Box drawing alignment tests: █
▉
╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
▝▀▘▙▄▟

BIN
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-32-with-le-bom.txt Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-32.txt Normal file
View file

Binary file not shown.

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-32.txt-utf8 Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫
⎪⎢⎜│a²+b³ ⎟⎥⎪
∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪
⎪⎢⎜⎷ c₈ ⎟⎥⎪
ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬
⎪⎢⎜ ∞ ⎟⎥⎪
⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪
⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭
Linguistics and dictionaries:
ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
APL:
((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
Nicer typography in plain text files:
╔══════════════════════════════════════════╗
║ ║
║ • ‘single’ and “double” quotes ║
║ ║
║ • Curly apostrophes: “We’ve been here” ║
║ ║
║ • Latin-1 apostrophe and accents: '´` ║
║ ║
║ • ‚deutsche‘ „Anführungszeichen“ ║
║ ║
║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
║ ║
║ • ASCII safety test: 1lI|, 0OD, 8B ║
║ ╭─────────╮ ║
║ • the euro symbol: │ 14.95 € │ ║
║ ╰─────────╯ ║
╚══════════════════════════════════════════╝
Combining characters:
STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑
Greek (in Polytonic):
The Greek anthem:
Σὲ γνωρίζω ἀπὸ τὴν κόψη
τοῦ σπαθιοῦ τὴν τρομερή,
σὲ γνωρίζω ἀπὸ τὴν ὄψη
ποὺ μὲ βία μετράει τὴ γῆ.
᾿Απ᾿ τὰ κόκκαλα βγαλμένη
τῶν ῾Ελλήνων τὰ ἱερά
καὶ σὰν πρῶτα ἀνδρειωμένη
χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
From a speech of Demosthenes in the 4th century BC:
Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
Georgian:
From a Unicode conference invitation:
გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
Russian:
From a Unicode conference invitation:
Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
Конференция соберет широкий круг экспертов по вопросам глобального
Интернета и Unicode, локализации и интернационализации, воплощению и
применению Unicode в различных операционных системах и программных
приложениях, шрифтах, верстке и многоязычных компьютерных системах.
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
ሰማይ አይታረስ ንጉሥ አይከሰስ።
ብላ ካለኝ እንደአባቴ በቆመጠኝ።
ጌጥ ያለቤቱ ቁምጥና ነው።
ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
የአፍ ወለምታ በቅቤ አይታሽም።
አይጥ በበላ ዳዋ ተመታ።
ሲተረጉሙ ይደረግሙ።
ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
ድር ቢያብር አንበሳ ያስር።
ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
ሥራ ከመፍታት ልጄን ላፋታት።
ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
ተንጋሎ ቢተፉ ተመልሶ ባፉ።
ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
እግርህን በፍራሽህ ልክ ዘርጋ።
Runes:
ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
–—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi<>⑀₂ἠḂӥẄɐː⍎אԱა
Greetings in various languages:
Hello world, Καλημέρα κόσμε, コンニチハ
Box drawing alignment tests: █
▉
╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
▝▀▘▙▄▟

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-8.txt Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫
⎪⎢⎜│a²+b³ ⎟⎥⎪
∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪
⎪⎢⎜⎷ c₈ ⎟⎥⎪
ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬
⎪⎢⎜ ∞ ⎟⎥⎪
⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪
⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭
Linguistics and dictionaries:
ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
APL:
((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
Nicer typography in plain text files:
╔══════════════════════════════════════════╗
║ ║
║ • ‘single’ and “double” quotes ║
║ ║
║ • Curly apostrophes: “We’ve been here” ║
║ ║
║ • Latin-1 apostrophe and accents: '´` ║
║ ║
║ • ‚deutsche‘ „Anführungszeichen“ ║
║ ║
║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
║ ║
║ • ASCII safety test: 1lI|, 0OD, 8B ║
║ ╭─────────╮ ║
║ • the euro symbol: │ 14.95 € │ ║
║ ╰─────────╯ ║
╚══════════════════════════════════════════╝
Combining characters:
STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑
Greek (in Polytonic):
The Greek anthem:
Σὲ γνωρίζω ἀπὸ τὴν κόψη
τοῦ σπαθιοῦ τὴν τρομερή,
σὲ γνωρίζω ἀπὸ τὴν ὄψη
ποὺ μὲ βία μετράει τὴ γῆ.
᾿Απ᾿ τὰ κόκκαλα βγαλμένη
τῶν ῾Ελλήνων τὰ ἱερά
καὶ σὰν πρῶτα ἀνδρειωμένη
χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
From a speech of Demosthenes in the 4th century BC:
Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
Georgian:
From a Unicode conference invitation:
გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
Russian:
From a Unicode conference invitation:
Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
Конференция соберет широкий круг экспертов по вопросам глобального
Интернета и Unicode, локализации и интернационализации, воплощению и
применению Unicode в различных операционных системах и программных
приложениях, шрифтах, верстке и многоязычных компьютерных системах.
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
ሰማይ አይታረስ ንጉሥ አይከሰስ።
ብላ ካለኝ እንደአባቴ በቆመጠኝ።
ጌጥ ያለቤቱ ቁምጥና ነው።
ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
የአፍ ወለምታ በቅቤ አይታሽም።
አይጥ በበላ ዳዋ ተመታ።
ሲተረጉሙ ይደረግሙ።
ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
ድር ቢያብር አንበሳ ያስር።
ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
ሥራ ከመፍታት ልጄን ላፋታት።
ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
ተንጋሎ ቢተፉ ተመልሶ ባፉ።
ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
እግርህን በፍራሽህ ልክ ዘርጋ።
Runes:
ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
–—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi<>⑀₂ἠḂӥẄɐː⍎אԱა
Greetings in various languages:
Hello world, Καλημέρα κόσμε, コンニチハ
Box drawing alignment tests: █
▉
╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
▝▀▘▙▄▟

212
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/tests/utf-8.txt-utf8 Normal file
View file

@ -0,0 +1,212 @@
UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
Markus Kuhn [ˈmaʳkʊs kuːn] <http://www.cl.cam.ac.uk/~mgk25/> — 2002-07-25
The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.
Using Unicode/UTF-8, you can write in emails and source code things such as
Mathematics and sciences:
∮ E⋅da = Q, n → ∞, ∑ f(i) = ∏ g(i), ⎧⎡⎛┌─────┐⎞⎤⎫
⎪⎢⎜│a²+b³ ⎟⎥⎪
∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β), ⎪⎢⎜│───── ⎟⎥⎪
⎪⎢⎜⎷ c₈ ⎟⎥⎪
ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ, ⎨⎢⎜ ⎟⎥⎬
⎪⎢⎜ ∞ ⎟⎥⎪
⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫), ⎪⎢⎜ ⎲ ⎟⎥⎪
⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm ⎩⎣⎝i=1 ⎠⎦⎭
Linguistics and dictionaries:
ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]
APL:
((V⍳V)=⍳⍴V)/V←,V ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈
Nicer typography in plain text files:
╔══════════════════════════════════════════╗
║ ║
║ • ‘single’ and “double” quotes ║
║ ║
║ • Curly apostrophes: “We’ve been here” ║
║ ║
║ • Latin-1 apostrophe and accents: '´` ║
║ ║
║ • ‚deutsche‘ „Anführungszeichen“ ║
║ ║
║ • †, ‡, ‰, •, 3–4, —, −5/+5, ™, … ║
║ ║
║ • ASCII safety test: 1lI|, 0OD, 8B ║
║ ╭─────────╮ ║
║ • the euro symbol: │ 14.95 € │ ║
║ ╰─────────╯ ║
╚══════════════════════════════════════════╝
Combining characters:
STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑
Greek (in Polytonic):
The Greek anthem:
Σὲ γνωρίζω ἀπὸ τὴν κόψη
τοῦ σπαθιοῦ τὴν τρομερή,
σὲ γνωρίζω ἀπὸ τὴν ὄψη
ποὺ μὲ βία μετράει τὴ γῆ.
᾿Απ᾿ τὰ κόκκαλα βγαλμένη
τῶν ῾Ελλήνων τὰ ἱερά
καὶ σὰν πρῶτα ἀνδρειωμένη
χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!
From a speech of Demosthenes in the 4th century BC:
Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
εἰς τοῦτο προήκοντα, ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.
Δημοσθένους, Γ´ ᾿Ολυνθιακὸς
Georgian:
From a Unicode conference invitation:
გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.
Russian:
From a Unicode conference invitation:
Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
Конференция соберет широкий круг экспертов по вопросам глобального
Интернета и Unicode, локализации и интернационализации, воплощению и
применению Unicode в различных операционных системах и программных
приложениях, шрифтах, верстке и многоязычных компьютерных системах.
Thai (UCS Level 2):
Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
classic 'San Gua'):
[----------------------------|------------------------]
๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช พระปกเกศกองบู๊กู้ขึ้นใหม่
สิบสองกษัตริย์ก่อนหน้าแลถัดไป สององค์ไซร้โง่เขลาเบาปัญญา
ทรงนับถือขันทีเป็นที่พึ่ง บ้านเมืองจึงวิปริตเป็นนักหนา
โฮจิ๋นเรียกทัพทั่วหัวเมืองมา หมายจะฆ่ามดชั่วตัวสำคัญ
เหมือนขับไสไล่เสือจากเคหา รับหมาป่าเข้ามาเลยอาสัญ
ฝ่ายอ้องอุ้นยุแยกให้แตกกัน ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
พลันลิฉุยกุยกีกลับก่อเหตุ ช่างอาเพศจริงหนาฟ้าร้องไห้
ต้องรบราฆ่าฟันจนบรรลัย ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ
(The above is a two-column text. If combining characters are handled
correctly, the lines of the second column should be aligned with the
| character above.)
Ethiopian:
Proverbs in the Amharic language:
ሰማይ አይታረስ ንጉሥ አይከሰስ።
ብላ ካለኝ እንደአባቴ በቆመጠኝ።
ጌጥ ያለቤቱ ቁምጥና ነው።
ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
የአፍ ወለምታ በቅቤ አይታሽም።
አይጥ በበላ ዳዋ ተመታ።
ሲተረጉሙ ይደረግሙ።
ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
ድር ቢያብር አንበሳ ያስር።
ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
ሥራ ከመፍታት ልጄን ላፋታት።
ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
ተንጋሎ ቢተፉ ተመልሶ ባፉ።
ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
እግርህን በፍራሽህ ልክ ዘርጋ።
Runes:
ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ
(Old English, which transcribed into Latin reads 'He cwaeth that he
bude thaem lande northweardum with tha Westsae.' and means 'He said
that he lived in the northern land near the Western Sea.')
Braille:
⡌⠁⠧⠑ ⠼⠁⠒ ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲
⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲
(The first couple of paragraphs of "A Christmas Carol" by Dickens)
Compact font selection example text:
ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
–—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi<>⑀₂ἠḂӥẄɐː⍎אԱა
Greetings in various languages:
Hello world, Καλημέρα κόσμε, コンニチハ
Box drawing alignment tests: █
▉
╔══╦══╗ ┌──┬──┐ ╭──┬──╮ ╭──┬──╮ ┏━━┳━━┓ ┎┒┏┑ ╷ ╻ ┏┯┓ ┌┰┐ ▊ ╱╲╱╲╳╳╳
║┌─╨─┐║ │╔═╧═╗│ │╒═╪═╕│ │╓─╁─╖│ ┃┌─╂─┐┃ ┗╃╄┙ ╶┼╴╺╋╸┠┼┨ ┝╋┥ ▋ ╲╱╲╱╳╳╳
║│╲ ╱│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╿ │┃ ┍╅╆┓ ╵ ╹ ┗┷┛ └┸┘ ▌ ╱╲╱╲╳╳╳
╠╡ ╳ ╞╣ ├╢ ╟┤ ├┼─┼─┼┤ ├╫─╂─╫┤ ┣┿╾┼╼┿┫ ┕┛┖┚ ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
║│╱ ╲│║ │║ ║│ ││ │ ││ │║ ┃ ║│ ┃│ ╽ │┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▎
║└─╥─┘║ │╚═╤═╝│ │╘═╪═╛│ │╙─╀─╜│ ┃└─╂─┘┃ ░░▒▒▓▓██ ┊ ┆ ╎ ╏ ┇ ┋ ▏
╚══╩══╝ └──┴──┘ ╰──┴──╯ ╰──┴──╯ ┗━━┻━━┛ ▗▄▖▛▀▜ └╌╌┘ ╎ ┗╍╍┛ ┋ ▁▂▃▄▅▆▇█
▝▀▘▙▄▟

46
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/.travis.yml Normal file
View file

@ -0,0 +1,46 @@
language: lisp
env:
matrix:
- LISP=allegro
- LISP=ccl
- LISP=ccl32
- LISP=sbcl
- LISP=sbcl32
- LISP=abcl
- LISP=cmucl
- LISP=ecl
matrix:
allow_failures:
- env: LISP=abcl
- env: LISP=cmucl
- env: LISP=ecl
notifications:
email:
on_success: change
on_failure: always
irc:
channels:
- "chat.freenode.net#iolib"
on_success: change
on_failure: always
use_notice: true
skip_join: true
install:
- curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh
- cl -e "(cl:in-package :cl-user)
(dolist (p '(:fiveam))
(ql:quickload p :verbose t))"
script:
- cl -e "(cl:in-package :cl-user)
(prin1 (lisp-implementation-type)) (terpri) (prin1 (lisp-implementation-version)) (terpri)
(ql:quickload :bordeaux-threads/test :verbose t)
(uiop:quit (if (some (lambda (x) (typep x '5am::test-failure))
(5am:run :bordeaux-threads))
1 0))"
sudo: required

19
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/CONTRIBUTORS Normal file
View file

@ -0,0 +1,19 @@
-*- outline -*-
Based on original Bordeaux-MP spec by Dan Barlow <dan@telent.net>
Contributors:
* Attila Lendvai <attila.lendvai@gmail.com>
- better handling of unsupported Lisps
* Vladimir Sekissov <svg@surnet.ru>
- fixes for CMUCL implementation
* Pierre Thierry <nowhere.man@levallois.eu.org>
- added license information
* Stelian Ionescu <sionescu@cddr.org>
- finished conversion from generic functions
- enabled running thread-safe code in unthreaded lisps
* Douglas Crosher <dtc@scieneer.com>
- added Scieneer Common Lisp support
* Daniel Kochmański <daniel@turtleware.eu>
- semaphores implementation

20
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/LICENSE Normal file
View file

@ -0,0 +1,20 @@
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

2
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/README Normal file
View file

@ -0,0 +1,2 @@
You can find API documentation on the project's wiki:
http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation

76
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/bordeaux-threads.asd Normal file
View file

@ -0,0 +1,76 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
#|
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version)))
(error "You need ASDF >= 3.1 to load this system correctly."))
(eval-when (:compile-toplevel :load-toplevel :execute)
#+(or armedbear
(and allegro multiprocessing)
(and clasp threads)
(and clisp mt)
(and openmcl openmcl-native-threads)
(and cmu mp)
corman
(and ecl threads)
genera
mkcl
lispworks
(and digitool ccl-5.1)
(and sbcl sb-thread)
scl)
(pushnew :thread-support *features*))
(defsystem :bordeaux-threads
:author "Greg Pfeil <greg@technomadic.org>"
:licence "MIT"
:description "Bordeaux Threads makes writing portable multi-threaded apps simple."
:version (:read-file-form "version.sexp")
:depends-on (:alexandria
#+(and allegro (version>= 9)) (:require "smputil")
#+(and allegro (not (version>= 9))) (:require "process")
#+corman (:require "threads"))
:components ((:static-file "version.sexp")
(:module "src"
:serial t
:components
((:file "pkgdcl")
(:file "bordeaux-threads")
(:file #+(and thread-support armedbear) "impl-abcl"
#+(and thread-support allegro) "impl-allegro"
#+(and thread-support clasp) "impl-clasp"
#+(and thread-support clisp) "impl-clisp"
#+(and thread-support openmcl) "impl-clozure"
#+(and thread-support cmu) "impl-cmucl"
#+(and thread-support corman) "impl-corman"
#+(and thread-support ecl) "impl-ecl"
#+(and thread-support genera) "impl-genera"
#+(and thread-support mkcl) "impl-mkcl"
#+(and thread-support lispworks) "impl-lispworks"
#+(and thread-support digitool) "impl-mcl"
#+(and thread-support sbcl) "impl-sbcl"
#+(and thread-support scl) "impl-scl"
#-thread-support "impl-null")
#+(and thread-support lispworks (or lispworks4 lispworks5))
(:file "impl-lispworks-condition-variables")
#+(and thread-support digitool)
(:file "condition-variables")
(:file "default-implementations")))))
(defsystem :bordeaux-threads/test
:author "Greg Pfeil <greg@technomadic.org>"
:description "Bordeaux Threads test suite."
:licence "MIT"
:version (:read-file-form "version.sexp")
:depends-on (:bordeaux-threads :fiveam)
:components ((:module "test"
:components ((:file "bordeaux-threads-test")))))
(defmethod perform ((o test-op) (c (eql (find-system :bordeaux-threads))))
(load-system :bordeaux-threads/test)
(symbol-call :5am :run! :bordeaux-threads))

55
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/site/index.html Normal file
View file

@ -0,0 +1,55 @@
<?xml version="1.0"?>
<!--
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
-->
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>Bordeaux Threads project</title>
<link rel="stylesheet" type="text/css" href="style.css"/>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
</head>
<body>
<div class="header">
<h1>Bordeaux Threads</h1>
<h2>Portable shared-state concurrency for Common Lisp</h2>
</div>
<p>Based on an original proposal by Dan Barlow (Bordeaux-MP) this
library is meant to make writing portable multi-threaded apps
simple.</p>
<p>Read the current <a href="http://trac.common-lisp.net/bordeaux-threads/wiki/ApiDocumentation">API documentation</a>.</p>
<p>Supports all major Common Lisp implementations: SBCL, CCL,
Lispworks, Allegro, ABCL, ECL, Clisp.<br/> The MKCL, Corman,
MCL and Scieneer backends are not tested frequently(if ever) and
might not work.</p>
<p>For discussion, use the mailing
list <a href="http://www.common-lisp.net/mailman/listinfo/bordeaux-threads-devel">bordeaux-threads-devel</a>
or the #lisp IRC channel on Freenode.</p>
<h3>Source repository</h3>
<p>Bordeaux-threads is developed
at <a href="https://github.com/sionescu/bordeaux-threads">Github</a>. The
repository is also mirrored
to <a href="https://gitlab.com/bordeaux-threads/bordeaux-threads">Gitlab</a>
and <a href="https://bitbucket.org/sionescu/bordeaux-threads">Bitbucket</a>.</p>
<div class="footer">
<a href="mailto:sionescu@cddr.org">Stelian Ionescu</a>. Last modified: <!--#flastmod file="index.shtml" -->
</div>
<div class="check">
<a href="http://validator.w3.org/check/referer">Valid XHTML 1.0 Strict</a>
</div>
</body>
</html>

86
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/site/style.css Normal file
View file

@ -0,0 +1,86 @@
/*
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
*/
tbody {
border-top: thin dotted black;
}
.failure {
background-color: #ff0;
}
.nonexistant {
background-color: #ccc;
}
.perfect {
background-color: #0f0;
}
.error {
background-color: #f00;
}
.header {
font-size: medium;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 5px;
border-color:#002244;
padding: 1mm 1mm 1mm 5mm;
}
.footer {
font-size: small;
font-style: italic;
text-align: right;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 2px;
border-color:#002244;
padding: 1mm 1mm 1mm 1mm;
}
.footer a:link {
font-weight:bold;
color:#ffffff;
background-color: #336699;
text-decoration:underline;
}
.footer a:visited {
font-weight:bold;
color:#ffffff;
background-color: #336699;
text-decoration:underline;
}
.footer a:hover {
font-weight:bold;
color:#002244;
background-color: #336699;
text-decoration:underline; }
.check {font-size: x-small;
text-align:right;}
.check a:link { font-weight:bold;
color:#a0a0ff;
background-color: #FFFFFF;
text-decoration:underline; }
.check a:visited { font-weight:bold;
color:#a0a0ff;
background-color: #FFFFFF;
text-decoration:underline; }
.check a:hover { font-weight:bold;
color:#000000;
background-color: #FFFFFF;
text-decoration:underline; }

170
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/bordeaux-threads.lisp Normal file
View file

@ -0,0 +1,170 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(defvar *supports-threads-p* nil
"This should be set to T if the running instance has thread support.")
(defun mark-supported ()
(setf *supports-threads-p* t)
(pushnew :bordeaux-threads *features*))
(define-condition bordeaux-mp-condition (error)
((message :initarg :message :reader message))
(:report (lambda (condition stream)
(format stream (message condition)))))
(defgeneric make-threading-support-error ()
(:documentation "Creates a BORDEAUX-THREADS condition which specifies
whether there is no BORDEAUX-THREADS support for the implementation, no
threads enabled for the system, or no support for a particular
function.")
(:method ()
(make-condition
'bordeaux-mp-condition
:message (if *supports-threads-p*
"There is no support for this method on this implementation."
"There is no thread support in this instance."))))
;;; Timeouts
#-sbcl
(define-condition timeout (serious-condition)
((length :initform nil
:initarg :length
:reader timeout-length))
(:report (lambda (c s)
(if (timeout-length c)
(format s "A timeout set to ~A seconds occurred."
(timeout-length c))
(format s "A timeout occurred.")))))
#-sbcl
(defmacro with-timeout ((timeout) &body body)
"Execute `BODY' and signal a condition of type TIMEOUT if the execution of
BODY does not complete within `TIMEOUT' seconds. On implementations which do not
support WITH-TIMEOUT natively and don't support threads either it has no effect."
(declare (ignorable timeout body))
#+thread-support
(let ((ok-tag (gensym "OK"))
(timeout-tag (gensym "TIMEOUT"))
(caller (gensym "CALLER")))
(once-only (timeout)
`(multiple-value-prog1
(catch ',ok-tag
(catch ',timeout-tag
(let ((,caller (current-thread)))
(make-thread #'(lambda ()
(sleep ,timeout)
(interrupt-thread ,caller
#'(lambda ()
(ignore-errors
(throw ',timeout-tag nil)))))
:name (format nil "WITH-TIMEOUT thread serving: ~S."
(thread-name ,caller)))
(throw ',ok-tag (progn ,@body))))
(error 'timeout :length ,timeout)))))
#-thread-support
`(error (make-threading-support-error)))
;;; Semaphores
;;; We provide this structure definition unconditionally regardless of the fact
;;; it may not be used not to prevent warnings from compiling default functions
;;; for semaphore in default-implementations.lisp.
(defstruct %semaphore
lock
condition-variable
counter)
#-(or ccl sbcl)
(deftype semaphore ()
'%semaphore)
;;; Thread Creation
;;; See default-implementations.lisp for MAKE-THREAD.
;; Forms are evaluated in the new thread or in the calling thread?
(defvar *default-special-bindings* nil
"This variable holds an alist associating special variable symbols
to forms to evaluate. Special variables named in this list will
be locally bound in the new thread before it begins executing user code.
This variable may be rebound around calls to MAKE-THREAD to
add/alter default bindings. The effect of mutating this list is
undefined, but earlier forms take precedence over later forms for
the same symbol, so defaults may be overridden by consing to the
head of the list.")
(defmacro defbindings (name docstring &body initforms)
(check-type docstring string)
`(defparameter ,name
(list
,@(loop for (special form) in initforms
collect `(cons ',special ',form)))
,docstring))
;; Forms are evaluated in the new thread or in the calling thread?
(defbindings *standard-io-bindings*
"Standard bindings of printer/reader control variables as per CL:WITH-STANDARD-IO-SYNTAX."
(*package* (find-package :common-lisp-user))
(*print-array* t)
(*print-base* 10)
(*print-case* :upcase)
(*print-circle* nil)
(*print-escape* t)
(*print-gensym* t)
(*print-length* nil)
(*print-level* nil)
(*print-lines* nil)
(*print-miser-width* nil)
(*print-pprint-dispatch* (copy-pprint-dispatch nil))
(*print-pretty* nil)
(*print-radix* nil)
(*print-readably* t)
(*print-right-margin* nil)
(*random-state* (make-random-state t))
(*read-base* 10)
(*read-default-float-format* 'single-float)
(*read-eval* t)
(*read-suppress* nil)
(*readtable* (copy-readtable nil)))
(defun binding-default-specials (function special-bindings)
"Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
FUNCTION."
(let ((specials (remove-duplicates special-bindings :from-end t :key #'car)))
(lambda ()
(progv (mapcar #'car specials)
(loop for (nil . form) in specials collect (eval form))
(funcall function)))))
;;; FIXME: This test won't work if CURRENT-THREAD
;;; conses a new object each time
(defun signal-error-if-current-thread (thread)
(when (eq thread (current-thread))
(error 'bordeaux-mp-condition
:message "Cannot destroy the current thread")))
(defparameter *no-condition-wait-timeout-message*
"CONDITION-WAIT with :TIMEOUT is not available for this Lisp implementation.")
(defun signal-error-if-condition-wait-timeout (timeout)
(when timeout
(error 'bordeaux-mp-condition
:message *no-condition-wait-timeout-message*)))
(defmacro define-condition-wait-compiler-macro ()
`(define-compiler-macro condition-wait
(&whole whole condition-variable lock &key timeout)
(declare (ignore condition-variable lock))
(when timeout
(simple-style-warning *no-condition-wait-timeout-message*))
whole))

38
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/condition-variables.lisp Normal file
View file

@ -0,0 +1,38 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; This file provides a portable implementation of condition
;;; variables (given a working WITH-LOCK-HELD and THREAD-YIELD), and
;;; should be used if there is no condition variable implementation in
;;; the host Lisp.
(defstruct condition-var
name
lock
active)
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(check-type condition-variable condition-var)
(setf (condition-var-active condition-variable) nil)
(release-lock lock)
(do ()
((when (condition-var-active condition-variable)
(acquire-lock lock)
t))
(thread-yield))
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) t)))

361
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/default-implementations.lisp Normal file
View file

@ -0,0 +1,361 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)
;;; Helper macros
(defmacro defdfun (name args doc &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',name)
(defun ,name ,args ,@body))
(setf (documentation ',name 'function)
(or (documentation ',name 'function) ,doc))))
(defmacro defdmacro (name args doc &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',name)
(defmacro ,name ,args ,@body))
(setf (documentation ',name 'function)
(or (documentation ',name 'function) ,doc))))
;;; Thread Creation
(defdfun start-multiprocessing ()
"If the host implementation uses user-level threads, start the
scheduler and multiprocessing, otherwise do nothing.
It is safe to call repeatedly."
nil)
(defdfun make-thread (function &key name
(initial-bindings *default-special-bindings*))
"Creates and returns a thread named NAME, which will call the
function FUNCTION with no arguments: when FUNCTION returns, the
thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied.
On systems that do not support multi-threading, MAKE-THREAD will
signal an error.
The interaction between threads and dynamic variables is in some
cases complex, and depends on whether the variable has only a global
binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
or has been bound locally (e.g. with LET or LET*) in the calling
thread.
- Global bindings are shared between threads: the initial value of a
global variable in the new thread will be the same as in the
parent, and an assignment to such a variable in any thread will be
visible to all threads in which the global binding is visible.
- Local bindings, such as the ones introduced by INITIAL-BINDINGS,
are local to the thread they are introduced in, except that
- Local bindings in the the caller of MAKE-THREAD may or may not be
shared with the new thread that it creates: this is
implementation-defined. Portable code should not depend on
particular behaviour in this case, nor should it assign to such
variables without first rebinding them in the new thread."
(%make-thread (binding-default-specials function initial-bindings)
(or name "Anonymous thread")))
(defdfun %make-thread (function name)
"The actual implementation-dependent function that creates threads."
(declare (ignore function name))
(error (make-threading-support-error)))
(defdfun current-thread ()
"Returns the thread object for the calling
thread. This is the same kind of object as would be returned by
MAKE-THREAD."
nil)
(defdfun threadp (object)
"Returns true if object is a thread, otherwise NIL."
(declare (ignore object))
nil)
(defdfun thread-name (thread)
"Returns the name of the thread, as supplied to MAKE-THREAD."
(declare (ignore thread))
"Main thread")
;;; Resource contention: locks and recursive locks
(defdfun lock-p (object)
"Returns T if OBJECT is a lock; returns NIL otherwise."
(declare (ignore object))
nil)
(defdfun recursive-lock-p (object)
"Returns T if OBJECT is a recursive lock; returns NIL otherwise."
(declare (ignore object))
nil)
(defdfun make-lock (&optional name)
"Creates a lock (a mutex) whose name is NAME. If the system does not
support multiple threads this will still return some object, but it
may not be used for very much."
;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if
;; there's some good reason it should be said structure or that it
;; be freshly consed - EQ comparison of locks?
(declare (ignore name))
(list nil))
(defdfun acquire-lock (lock &optional wait-p)
"Acquire the lock LOCK for the calling thread.
WAIT-P governs what happens if the lock is not available: if WAIT-P
is true, the calling thread will wait until the lock is available
and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return
immediately. ACQUIRE-LOCK returns true if the lock was acquired and
NIL otherwise.
This specification does not define what happens if a thread
attempts to acquire a lock that it already holds. For applications
that require locks to be safe when acquired recursively, see instead
MAKE-RECURSIVE-LOCK and friends."
(declare (ignore lock wait-p))
t)
(defdfun release-lock (lock)
"Release LOCK. It is an error to call this unless
the lock has previously been acquired (and not released) by the same
thread. If other threads are waiting for the lock, the
ACQUIRE-LOCK call in one of them will now be able to continue.
This function has no interesting return value."
(declare (ignore lock))
(values))
(defdmacro with-lock-held ((place) &body body)
"Evaluates BODY with the lock named by PLACE, the value of which
is a lock created by MAKE-LOCK. Before the forms in BODY are
evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
forms in BODY have been evaluated, or if a non-local control transfer
is caused (e.g. by THROW or SIGNAL), the lock is released as if by
RELEASE-LOCK.
Note that if the debugger is entered, it is unspecified whether the
lock is released at debugger entry or at debugger exit when execution
is restarted."
`(when (acquire-lock ,place t)
(unwind-protect
(locally ,@body)
(release-lock ,place))))
(defdfun make-recursive-lock (&optional name)
"Create and return a recursive lock whose name is NAME. A recursive
lock differs from an ordinary lock in that a thread that already
holds the recursive lock can acquire it again without blocking. The
thread must then release the lock twice before it becomes available
for another thread."
(declare (ignore name))
(list nil))
(defdfun acquire-recursive-lock (lock)
"As for ACQUIRE-LOCK, but for recursive locks."
(declare (ignore lock))
t)
(defdfun release-recursive-lock (lock)
"Release the recursive LOCK. The lock will only
become free after as many Release operations as there have been
Acquire operations. See RELEASE-LOCK for other information."
(declare (ignore lock))
(values))
(defdmacro with-recursive-lock-held ((place &key timeout) &body body)
"Evaluates BODY with the recursive lock named by PLACE, which is a
reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See
WITH-LOCK-HELD etc etc"
(declare (ignore timeout))
`(when (acquire-recursive-lock ,place)
(unwind-protect
(locally ,@body)
(release-recursive-lock ,place))))
;;; Resource contention: condition variables
;;; A condition variable provides a mechanism for threads to put
;;; themselves to sleep while waiting for the state of something to
;;; change, then to be subsequently woken by another thread which has
;;; changed the state.
;;;
;;; A condition variable must be used in conjunction with a lock to
;;; protect access to the state of the object of interest. The
;;; procedure is as follows:
;;;
;;; Suppose two threads A and B, and some kind of notional event
;;; channel C. A is consuming events in C, and B is producing them.
;;; CV is a condition-variable
;;;
;;; 1) A acquires the lock that safeguards access to C
;;; 2) A threads and removes all events that are available in C
;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically
;;; releases the lock and puts A to sleep on CV
;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again
;;; before returning
;;; 5) Loop back to step 2, for as long as threading should continue
;;;
;;; When B generates an event E, it
;;; 1) acquires the lock guarding C
;;; 2) adds E to the channel
;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread
;;; 4) releases the lock
;;;
;;; To avoid the "lost wakeup" problem, the implementation must
;;; guarantee that CONDITION-WAIT in thread A atomically releases the
;;; lock and sleeps. If this is not guaranteed there is the
;;; possibility that thread B can add an event and call
;;; CONDITION-NOTIFY between the lock release and the sleep - in this
;;; case the notify call would not see A, which would be left sleeping
;;; despite there being an event available.
(defdfun thread-yield ()
"Allows other threads to run. It may be necessary or desirable to
call this periodically in some implementations; others may schedule
threads automatically. On systems that do not support
multi-threading, this does nothing."
(values))
(defdfun make-condition-variable (&key name)
"Returns a new condition-variable object for use
with CONDITION-WAIT and CONDITION-NOTIFY."
(declare (ignore name))
nil)
(defdfun condition-wait (condition-variable lock &key timeout)
"Atomically release LOCK and enqueue the calling
thread waiting for CONDITION-VARIABLE. The thread will resume when
another thread has notified it using CONDITION-NOTIFY; it may also
resume if interrupted by some external event or in other
implementation-dependent circumstances: the caller must always test
on waking that there is threading to be done, instead of assuming
that it can go ahead.
It is an error to call function this unless from the thread that
holds LOCK.
If TIMEOUT is nil or not provided, the system always reacquires LOCK
before returning to the caller. In this case T is returned.
If TIMEOUT is non-nil, the call will return after at most TIMEOUT
seconds (approximately), whether or not a notification has occurred.
Either NIL or T will be returned. A return of NIL indicates that the
lock is no longer held and that the timeout has expired. A return of
T indicates that the lock is held, in which case the timeout may or
may not have expired.
**NOTE**: The behavior of CONDITION-WAIT with TIMEOUT diverges from
the POSIX function pthread_cond_timedwait. The former may return
without the lock being held while the latter always returns with the
lock held.
In an implementation that does not support multiple threads, this
function signals an error."
(declare (ignore condition-variable lock timeout))
(error (make-threading-support-error)))
(defdfun condition-notify (condition-variable)
"Notify at least one of the threads waiting for
CONDITION-VARIABLE. It is implementation-dependent whether one or
more than one (and possibly all) threads are woken, but if the
implementation is capable of waking only a single thread (not all
are) this is probably preferable for efficiency reasons. The order
of wakeup is unspecified and does not necessarily relate to the
order that the threads went to sleep in.
CONDITION-NOTIFY has no useful return value. In an implementation
that does not support multiple threads, it has no effect."
(declare (ignore condition-variable))
(values))
;;; Resource contention: semaphores
(defdfun make-semaphore (&key name (count 0))
"Create a semaphore with the supplied NAME and initial counter value COUNT."
(make-%semaphore :lock (make-lock name)
:condition-variable (make-condition-variable :name name)
:counter count))
(defdfun signal-semaphore (semaphore &key (count 1))
"Increment SEMAPHORE by COUNT. If there are threads waiting on this
semaphore, then COUNT of them are woken up."
(with-lock-held ((%semaphore-lock semaphore))
(incf (%semaphore-counter semaphore) count)
(dotimes (v count)
(condition-notify (%semaphore-condition-variable semaphore))))
(values))
(defdfun wait-on-semaphore (semaphore &key timeout)
"Decrement the count of SEMAPHORE by 1 if the count would not be negative.
Else blocks until the semaphore can be decremented. Returns generalized boolean
T on success.
If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
cannot be decremented in that time, returns NIL without decrementing the count."
(with-lock-held ((%semaphore-lock semaphore))
(if (>= (%semaphore-counter semaphore) 1)
(decf (%semaphore-counter semaphore))
(let ((deadline (when timeout
(+ (get-internal-real-time)
(* timeout internal-time-units-per-second)))))
;; we need this loop because of a spurious wakeup possibility
(loop until (>= (%semaphore-counter semaphore) 1)
do (cond
((null (condition-wait (%semaphore-condition-variable semaphore)
(%semaphore-lock semaphore)
:timeout timeout))
(return-from wait-on-semaphore))
;; unfortunately cv-wait may return T on timeout too
((and deadline (>= (get-internal-real-time) deadline))
(return-from wait-on-semaphore))
(timeout
(setf timeout (/ (- deadline (get-internal-real-time))
internal-time-units-per-second)))))
(decf (%semaphore-counter semaphore))))))
(defdfun semaphore-p (object)
"Returns T if OBJECT is a semaphore; returns NIL otherwise."
(typep object 'semaphore))
;;; Introspection/debugging
;;; The following functions may be provided for debugging purposes,
;;; but are not advised to be called from normal user code.
(defdfun all-threads ()
"Returns a sequence of all of the threads. This may not
be freshly-allocated, so the caller should not modify it."
(error (make-threading-support-error)))
(defdfun interrupt-thread (thread function)
"Interrupt THREAD and cause it to evaluate FUNCTION
before continuing with the interrupted path of execution. This may
not be a good idea if THREAD is holding locks or doing anything
important. On systems that do not support multiple threads, this
function signals an error."
(declare (ignore thread function))
(error (make-threading-support-error)))
(defdfun destroy-thread (thread)
"Terminates the thread THREAD, which is an object
as returned by MAKE-THREAD. This should be used with caution: it is
implementation-defined whether the thread runs cleanup forms or
releases its locks first.
Destroying the calling thread is an error."
(declare (ignore thread))
(error (make-threading-support-error)))
(defdfun thread-alive-p (thread)
"Returns true if THREAD is alive, that is, if
DESTROY-THREAD has not been called on it."
(declare (ignore thread))
(error (make-threading-support-error)))
(defdfun join-thread (thread)
"Wait until THREAD terminates. If THREAD has already terminated,
return immediately. The return values of the thread function are
returned."
(declare (ignore thread))
(error (make-threading-support-error)))

150
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-abcl.lisp Normal file
View file

@ -0,0 +1,150 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; the implementation of the Armed Bear thread interface can be found in
;;; src/org/armedbear/lisp/LispThread.java
(deftype thread ()
'threads:thread)
;;; Thread Creation
(defun %make-thread (function name)
(threads:make-thread function :name name))
(defun current-thread ()
(threads:current-thread))
(defun thread-name (thread)
(threads:thread-name thread))
(defun threadp (object)
(typep object 'thread))
;;; Resource contention: locks and recursive locks
(defstruct mutex name lock)
(defstruct (mutex-recursive (:include mutex)))
;; Making methods constants in this manner avoids the runtime expense of
;; introspection involved in JCALL with string arguments.
(defconstant +lock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
(defconstant +try-lock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
(defconstant +is-held-by-current-thread+
(jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
(defconstant +unlock+
(jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
(defconstant +get-hold-count+
(jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
(deftype lock () 'mutex)
(deftype recursive-lock () 'mutex-recursive)
(defun lock-p (object)
(typep object 'mutex))
(defun recursive-lock-p (object)
(typep object 'mutex-recursive))
(defun make-lock (&optional name)
(make-mutex
:name (or name "Anonymous lock")
:lock (jnew "java.util.concurrent.locks.ReentrantLock")))
(defun acquire-lock (lock &optional (wait-p t))
(check-type lock mutex)
(when (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Non-recursive lock being reacquired by owner."))
(cond
(wait-p
(jcall +lock+ (mutex-lock lock))
t)
(t (jcall +try-lock+ (mutex-lock lock)))))
(defun release-lock (lock)
(check-type lock mutex)
(unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Attempt to release lock not held by calling thread."))
(jcall +unlock+ (mutex-lock lock))
(values))
(defun make-recursive-lock (&optional name)
(make-mutex-recursive
:name (or name "Anonymous lock")
:lock (jnew "java.util.concurrent.locks.ReentrantLock")))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(check-type lock mutex-recursive)
(cond
(wait-p
(jcall +lock+ (mutex-recursive-lock lock))
t)
(t (jcall +try-lock+ (mutex-recursive-lock lock)))))
(defun release-recursive-lock (lock)
(check-type lock mutex-recursive)
(unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
(error "Attempt to release lock not held by calling thread."))
(jcall +unlock+ (mutex-lock lock))
(values))
;;; Resource contention: condition variables
(defun thread-yield ()
(java:jstatic "yield" "java.lang.Thread"))
(defstruct condition-variable
(name "Anonymous condition variable"))
(defun condition-wait (condition lock &key timeout)
(threads:synchronized-on condition
(release-lock lock)
(if timeout
;; Since giving a zero time value to threads:object-wait means
;; an indefinite wait, use some arbitrary small number.
(threads:object-wait condition
(if (zerop timeout)
least-positive-single-float
timeout))
(threads:object-wait condition)))
(acquire-lock lock)
t)
(defun condition-notify (condition)
(threads:synchronized-on condition
(threads:object-notify condition)))
;;; Introspection/debugging
(defun all-threads ()
(let ((threads ()))
(threads:mapcar-threads (lambda (thread)
(push thread threads)))
(reverse threads)))
(defun interrupt-thread (thread function &rest args)
(apply #'threads:interrupt-thread thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(threads:destroy-thread thread))
(defun thread-alive-p (thread)
(threads:thread-alive-p thread))
(defun join-thread (thread)
(threads:thread-join thread))
(mark-supported)

143
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-allegro.lisp Normal file
View file

@ -0,0 +1,143 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the Allegro Multiprocessing interface can be found at
;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:process-lock)
(deftype recursive-lock () 'mp:process-lock)
(defun lock-p (object)
(typep object 'mp:process-lock))
(defun recursive-lock-p (object)
(typep object 'mp:process-lock))
(defun make-lock (&optional name)
(mp:make-process-lock :name (or name "Anonymous lock")))
(defun make-recursive-lock (&optional name)
(mp:make-process-lock :name (or name "Anonymous recursive lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0)))
(defun release-lock (lock)
(mp:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-process-lock (,place :norecursive t)
,@body))
(defmacro with-recursive-lock-held ((place &key timeout) &body body)
`(mp:with-process-lock (,place :timeout ,timeout)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignorable name))
#-(version>= 9)
(mp:make-gate nil)
#+(version>= 9)
(mp:make-condition-variable :name name))
(defun condition-wait (condition-variable lock &key timeout)
#-(version>= 9)
(progn
(release-lock lock)
(if timeout
(mp:process-wait-with-timeout "wait for message" timeout
#'mp:gate-open-p condition-variable)
(mp:process-wait "wait for message" #'mp:gate-open-p condition-variable))
(acquire-lock lock)
(mp:close-gate condition-variable))
#+(version>= 9)
(mp:condition-variable-wait condition-variable lock :timeout timeout)
t)
(defun condition-notify (condition-variable)
#-(version>= 9)
(mp:open-gate condition-variable)
#+(version>= 9)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-allow-schedule))
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp:start-scheduler))
(defun %make-thread (function name)
#+smp
(mp:process-run-function name function)
#-smp
(mp:process-run-function
name
(lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (getf (mp:process-property-list mp:*current-process*)
'return-values)
return-values)
(values-list return-values)))))
(defun current-thread ()
mp:*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
(defun all-threads ()
mp:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(apply #'mp:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(defun join-thread (thread)
#+smp
(values-list (mp:process-join thread))
#-smp
(progn
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(complement #'mp:process-alive-p)
thread)
(let ((return-values
(getf (mp:process-property-list thread) 'return-values)))
(values-list return-values))))
(mark-supported)

111
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clasp.lisp Normal file
View file

@ -0,0 +1,111 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the ECL Multiprocessing interface can be found at
;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun %make-thread (function name)
(mp:process-run-function name function bordeaux-threads:*default-special-bindings*))
(defun current-thread ()
mp:*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:mutex)
(deftype recursive-lock ()
'(and mp:mutex (satisfies mp:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mp:mutex))
(defun recursive-lock-p (object)
(and (typep object 'mp:lock)
(mp:recursive-lock-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name :anonymous)))
(defun acquire-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-lock (lock)
(mp:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-recursive-mutex (or name :anonymous-recursive-lock)))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mp:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mp:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(mp:condition-variable-timedwait condition-variable lock timeout)
(mp:condition-variable-wait condition-variable lock))
t)
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:interrupt-process thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
(mp:process-join thread))
(mark-supported)

105
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clisp.lisp Normal file
View file

@ -0,0 +1,105 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mt:thread)
;;; Thread Creation
(defun %make-thread (function name)
(mt:make-thread function
:name name
:initial-bindings mt:*default-special-bindings*))
(defun current-thread ()
(mt:current-thread))
(defun threadp (object)
(mt:threadp object))
(defun thread-name (thread)
(mt:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mt:mutex)
(deftype recursive-lock ()
'(and mt:mutex (satisfies mt:mutex-recursive-p)))
(defun lock-p (object)
(typep object 'mt:mutex))
(defun recursive-lock-p (object)
(and (typep object 'mt:mutex)
(mt:mutex-recursive-p object)))
(defun make-lock (&optional name)
(mt:make-mutex :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mt:mutex-lock lock :timeout (if wait-p nil 0)))
(defun release-lock (lock)
(mt:mutex-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mt:with-mutex-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mt:make-mutex :name (or name "Anonymous recursive lock")
:recursive-p t))
(defmacro with-recursive-lock-held ((place) &body body)
`(mt:with-mutex-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(mt:make-exemption :name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(mt:exemption-wait condition-variable lock :timeout timeout)
t)
(defun condition-notify (condition-variable)
(mt:exemption-signal condition-variable))
(defun thread-yield ()
(mt:thread-yield))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
(defun all-threads ()
(delete-if-not #'mt:thread-active-p (mt:list-threads)))
(defun interrupt-thread (thread function &rest args)
(mt:thread-interrupt thread :function function :arguments args))
(defun destroy-thread (thread)
;;; VTZ: actually we can kill ourselelf.
;;; suicide is part of our contemporary life :)
(signal-error-if-current-thread thread)
(mt:thread-interrupt thread :function t))
(defun thread-alive-p (thread)
(mt:thread-active-p thread))
(defun join-thread (thread)
(mt:thread-join thread))
(mark-supported)

130
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-clozure.lisp Normal file
View file

@ -0,0 +1,130 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the OpenMCL Threads interface can be found at
;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html
(deftype thread ()
'ccl:process)
;;; Thread Creation
(defun %make-thread (function name)
(ccl:process-run-function name function))
(defun current-thread ()
ccl:*current-process*)
(defun threadp (object)
(typep object 'ccl:process))
(defun thread-name (thread)
(ccl:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'ccl:lock)
(deftype recursive-lock () 'ccl:lock)
(defun lock-p (object)
(typep object 'ccl:lock))
(defun recursive-lock-p (object)
(typep object 'ccl:lock))
(defun make-lock (&optional name)
(ccl:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(ccl:grab-lock lock)
(ccl:try-lock lock)))
(defun release-lock (lock)
(ccl:release-lock lock))
(defmacro with-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place)
,@body))
(defun make-recursive-lock (&optional name)
(ccl:make-lock (or name "Anonymous recursive lock")))
(defun acquire-recursive-lock (lock)
(ccl:grab-lock lock))
(defun release-recursive-lock (lock)
(ccl:release-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(ccl:make-semaphore))
(defun condition-wait (condition-variable lock &key timeout)
(release-lock lock)
(unwind-protect
(if timeout
(ccl:timed-wait-on-semaphore condition-variable timeout)
(ccl:wait-on-semaphore condition-variable))
(acquire-lock lock t))
t)
(defun condition-notify (condition-variable)
(ccl:signal-semaphore condition-variable))
(defun thread-yield ()
(ccl:process-allow-schedule))
;;; Semaphores
(deftype semaphore ()
'ccl:semaphore)
(defun make-semaphore (&key name (count 0))
(declare (ignore name))
(let ((semaphore (ccl:make-semaphore)))
(dotimes (c count) (ccl:signal-semaphore semaphore))
semaphore))
(defun signal-semaphore (semaphore &key (count 1))
(dotimes (c count) (ccl:signal-semaphore semaphore)))
(defun wait-on-semaphore (semaphore &key timeout)
(if timeout
(ccl:timed-wait-on-semaphore semaphore timeout)
(ccl:wait-on-semaphore semaphore)))
;;; Introspection/debugging
(defun all-threads ()
(ccl:all-processes))
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'ccl:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(ccl:process-kill thread))
(defun thread-alive-p (thread)
(not (ccl:process-exhausted-p thread)))
(defun join-thread (thread)
(ccl:join-process thread))
(mark-supported)

161
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-cmucl.lisp Normal file
View file

@ -0,0 +1,161 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mp::process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp::startup-idle-and-top-level-loops))
(defun %make-thread (function name)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:make-process function :name name)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:make-process (lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (getf (mp:process-property-list mp:*current-process*)
'return-values)
return-values)
(values-list return-values)))
:name name))
(defun current-thread ()
mp:*current-process*)
(defmethod threadp (object)
(mp:processp object))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp::error-check-lock)
(deftype recursive-lock () 'mp::recursive-lock)
(defun lock-p (object)
(typep object 'mp::error-check-lock))
(defun recursive-lock-p (object)
(typep object 'mp::recursive-lock))
(defun make-lock (&optional name)
(mp:make-lock (or name "Anonymous lock")
:kind :error-check))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(mp::lock-wait lock "Lock wait")
(mp::lock-wait-with-timeout lock "Lock wait" 0)))
(defun release-lock (lock)
(setf (mp::lock-process lock) nil))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock-held (,place "Lock wait") ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock (or name "Anonymous recursive lock")
:kind :recursive))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(acquire-lock lock))
(defun release-recursive-lock (lock)
(release-lock lock))
(defmacro with-recursive-lock-held ((place &key timeout) &body body)
`(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body))
;;; Note that the locks _are_ recursive, but not "balanced", and only
;;; checked if they are being held by the same process by with-lock-held.
;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that
;;; it will wait for recursive locks by the same process as well.
;;; Resource contention: condition variables
;;; There's some stuff in x86-vm.lisp that might be worth investigating
;;; whether to build on. There's also process-wait and friends.
(defstruct condition-var
"CMUCL doesn't have conditions, so we need to create our own type."
name
lock
active)
(defun make-condition-variable (&key name)
(make-condition-var :lock (make-lock)
:name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) nil))
(release-lock lock)
(mp:process-wait "Condition Wait"
#'(lambda () (condition-var-active condition-variable)))
(acquire-lock lock)
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(check-type condition-variable condition-var)
(with-lock-held ((condition-var-lock condition-variable))
(setf (condition-var-active condition-variable) t))
(thread-yield))
(defun thread-yield ()
(mp:process-yield))
;;; Timeouts
(defmacro with-timeout ((timeout) &body body)
(once-only (timeout)
`(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
,@body)))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:process-interrupt thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:destroy-process thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-join thread)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(progn
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(lambda () (not (mp:process-alive-p thread))))
(let ((return-values
(getf (mp:process-property-list thread) 'return-values)))
(values-list return-values))))
(mark-supported)

26
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-corman.lisp Normal file
View file

@ -0,0 +1,26 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; Thread Creation
(defun %make-thread (function name)
(declare (ignore name))
(threads:create-thread function))
(defun current-thread ()
threads:*current-thread*)
;;; Introspection/debugging
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(threads:terminate-thread thread))
(mark-supported)

111
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-ecl.lisp Normal file
View file

@ -0,0 +1,111 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the ECL Multiprocessing interface can be found at
;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun %make-thread (function name)
(mp:process-run-function name function))
(defun current-thread ()
mp::*current-process*)
(defun threadp (object)
(typep object 'mp:process))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:lock)
(deftype recursive-lock ()
'(and mp:lock (satisfies mp:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mp:lock))
(defun recursive-lock-p (object)
(and (typep object 'mp:lock)
(mp:recursive-lock-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-lock (lock)
(mp:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock :name (or name "Anonymous recursive lock") :recursive t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mp:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mp:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mp:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(handler-case (with-timeout (timeout)
(mp:condition-variable-wait condition-variable lock))
(timeout () nil))
(mp:condition-variable-wait condition-variable lock)))
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mp:interrupt-process thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-active-p thread))
(defun join-thread (thread)
(mp:process-join thread))
(mark-supported)

136
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-genera.lisp Normal file
View file

@ -0,0 +1,136 @@
;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*-
#|
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'process:process)
;;; Thread Creation
(defun %make-thread (function name)
(process:process-run-function name function))
(defun current-thread ()
scl:*current-process*)
(defun threadp (object)
(process:process-p object))
(defun thread-name (thread)
(process:process-name thread))
;;; Resource contention: locks and recursive locks
(defstruct (lock (:constructor make-lock-internal))
lock
lock-argument)
(defun make-lock (&optional name)
(let ((lock (process:make-lock (or name "Anonymous lock"))))
(make-lock-internal :lock lock
:lock-argument nil)))
(defun acquire-lock (lock &optional (wait-p t))
(check-type lock lock)
(setf (lock-lock-argument lock) (process:make-lock-argument (lock-lock lock)))
(if wait-p
(process:lock (lock-lock lock) (lock-lock-argument lock))
(process:with-no-other-processes
(when (process:lock-lockable-p (lock-lock lock))
(process:lock (lock-lock lock) (lock-lock-argument lock))))))
(defun release-lock (lock)
(check-type lock lock)
(process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil)))
(defmacro with-lock-held ((place) &body body)
`(process:with-lock ((lock-lock ,place))
,@body))
(defstruct (recursive-lock (:constructor make-recursive-lock-internal))
lock
lock-arguments)
(defun make-recursive-lock (&optional name)
(make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock")
:recursive t)
:lock-arguments nil))
(defun acquire-recursive-lock (lock)
(check-type lock recursive-lock)
(process:lock (recursive-lock-lock lock)
(car (push (process:make-lock-argument (recursive-lock-lock lock))
(recursive-lock-lock-arguments lock)))))
(defun release-recursive-lock (lock)
(check-type lock recursive-lock)
(process:unlock (recursive-lock-lock lock) (pop (recursive-lock-lock-arguments lock))))
(defmacro with-recursive-lock-held ((place) &body body)
`(process:with-lock ((recursive-lock-lock ,place))
,@body))
;;; Resource contention: condition variables
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (condition-variable (:constructor %make-condition-variable))
name
(waiters nil))
)
(defun make-condition-variable (&key name)
(%make-condition-variable :name name))
(defun condition-wait (condition-variable lock)
(check-type condition-variable condition-variable)
(check-type lock lock)
(process:with-no-other-processes
(let ((waiter (cons scl:*current-process* nil)))
(process:atomic-updatef (condition-variable-waiters condition-variable)
#'(lambda (waiters)
(append waiters (scl:ncons waiter))))
(process:without-lock ((lock-lock lock))
(process:process-block (format nil "Waiting~@[ on ~A~]"
(condition-variable-name condition-variable))
#'(lambda (waiter)
(not (null (cdr waiter))))
waiter)))))
(defun condition-notify (condition-variable)
(check-type condition-variable condition-variable)
(let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable))))
(when waiter
(setf (cdr waiter) t)
(process:wakeup (car waiter))))
(values))
(defun thread-yield ()
(scl:process-allow-schedule))
;;; Introspection/debugging
(defun all-threads ()
process:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'process:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(process:process-kill thread :without-aborts :force))
(defun thread-alive-p (thread)
(process:process-active-p thread))
(defun join-thread (thread)
(process:process-wait (format nil "Join ~S" thread)
#'(lambda (thread)
(not (process:process-active-p thread)))
thread))
(mark-supported)

144
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-lispworks-condition-variables.lisp Normal file
View file

@ -0,0 +1,144 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)
;; Lispworks condition support is simulated, albeit via a lightweight wrapper over
;; its own polling-based wait primitive. Waiters register with the condition variable,
;; and use MP:process-wait which queries for permission to proceed at its own (usspecified) interval.
;; http://www.lispworks.com/documentation/lw51/LWRM/html/lwref-445.htm
;; A wakeup callback (on notify) is provided to lighten this query to not have to do a hash lookup
;; on every poll (or have to serialize on the condition variable) and a mechanism is put
;; in place to unregister any waiter that exits wait for other reasons,
;; and to resend any (single) notification that may have been consumed before this (corner
;; case). Much of the complexity present is to support single notification (as recommended in
;; the spec); but a distinct condition-notify-all is provided for reference.
;; Single-notification follows a first-in first-out ordering
;;
;; Performance: With 1000 threads waiting on one condition-variable, the steady-state hit (at least
;; as tested on a 3GHz Win32 box) is noise - hovering at 0% on Task manager.
;; While not true zero like a true native solution, the use of the Lispworks native checks appear
;; fast enough to be an equivalent substitute (thread count will cause issue before the
;; waiting overhead becomes significant)
(defstruct (condition-variable (:constructor make-lw-condition (name)))
name
(lock (mp:make-lock :name "For condition-variable") :type mp:lock :read-only t)
(wait-tlist (cons nil nil) :type cons :read-only t)
(wait-hash (make-hash-table :test 'eq) :type hash-table :read-only t)
;; unconsumed-notifications is to track :remove-from-consideration
;; for entries that may have exited prematurely - notification is sent through
;; to someone else, and offender is removed from hash and list
(unconsumed-notifications (make-hash-table :test 'eq) :type hash-table :read-only t))
(defun make-condition-variable (&key name)
(make-lw-condition name))
(defmacro with-cv-access (condition-variable &body body)
(let ((cv-sym (gensym))
(slots '(lock wait-tlist wait-hash unconsumed-notifications)))
`(let ((,cv-sym ,condition-variable))
(with-slots ,slots
,cv-sym
(macrolet ((locked (&body body) `(mp:with-lock (lock) ,@body)))
(labels ((,(gensym) () ,@slots))) ; Trigger expansion of the symbol-macrolets to ignore
,@body)))))
(defmacro defcvfun (function-name (condition-variable &rest args) &body body)
`(defun ,function-name (,condition-variable ,@args)
(with-cv-access ,condition-variable
,@body)))
#+lispworks (editor:setup-indent "defcvfun" 2 2 7) ; indent defcvfun
; utility function thath assumes process is locked on condition-variable's lock.
(defcvfun do-notify-single (condition-variable) ; assumes already locked
(let ((id (caar wait-tlist)))
(when id
(pop (car wait-tlist))
(unless (car wait-tlist) ; check for empty
(setf (cdr wait-tlist) nil))
(funcall (gethash id wait-hash)) ; call waiter-wakeup
(remhash id wait-hash) ; absence of entry = permission to proceed
(setf (gethash id unconsumed-notifications) t))))
;; Added for completeness/to show how it's done in this paradigm; but
;; The symbol for this call is not exposed in the api
(defcvfun condition-notify-all (condition-variable)
(locked
(loop for waiter-wakeup being the hash-values in wait-hash do (funcall waiter-wakeup))
(clrhash wait-hash)
(clrhash unconsumed-notifications) ; don't care as everyone just got notified
(setf (car wait-tlist) nil)
(setf (cdr wait-tlist) nil)))
;; Currently implemented so as to notify only one waiting thread
(defcvfun condition-notify (condition-variable)
(locked (do-notify-single condition-variable)))
(defun delete-from-tlist (tlist element)
(let ((deleter
(lambda ()
(setf (car tlist) (cdar tlist))
(unless (car tlist)
(setf (cdr tlist) nil)))))
(loop for cons in (car tlist) do
(if (eq element (car cons))
(progn
(funcall deleter)
(return nil))
(let ((cons cons))
(setq deleter
(lambda ()
(setf (cdr cons) (cddr cons))
(unless (cdr cons)
(setf (cdr tlist) cons)))))))))
(defun add-to-tlist-tail (tlist element)
(let ((new-link (cons element nil)))
(cond
((car tlist)
(setf (cddr tlist) new-link)
(setf (cdr tlist) new-link))
(t
(setf (car tlist) new-link)
(setf (cdr tlist) new-link)))))
(defcvfun condition-wait (condition-variable lock- &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(mp:process-unlock lock-)
(unwind-protect ; for the re-taking of the lock. Guarding all of the code
(let ((wakeup-allowed-to-proceed nil)
(wakeup-lock (mp:make-lock :name "wakeup lock for condition-wait")))
;; wakeup-allowed-to-proceed is an optimisation to avoid having to serialize all waiters and
;; search the hashtable. That it is locked is for safety/completeness, although
;; as wakeup-allowed-to-proceed only transitions nil -> t, and that missing it once or twice is
;; moot in this situation, it would be redundant even if ever a Lispworks implementation ever became
;; non-atomic in its assigments
(let ((id (cons nil nil))
(clean-exit nil))
(locked
(add-to-tlist-tail wait-tlist id)
(setf (gethash id wait-hash) (lambda () (mp:with-lock (wakeup-lock) (setq wakeup-allowed-to-proceed t)))))
(unwind-protect
(progn
(mp:process-wait
"Waiting for notification"
(lambda ()
(when (mp:with-lock (wakeup-lock) wakeup-allowed-to-proceed)
(locked (not (gethash id wait-hash))))))
(locked (remhash id unconsumed-notifications))
(setq clean-exit t)) ; Notification was consumed
;; Have to call remove-from-consideration just in case process was interrupted
;; rather than having condition met
(unless clean-exit ; clean-exit is just an optimization
(locked
(when (gethash id wait-hash) ; not notified - must have been interrupted
;; Have to unsubscribe
(remhash id wait-hash)
(delete-from-tlist wait-tlist id))
;; note - it's possible to be removed from wait-hash/wait-tlist (in notify-single); but still have an unconsumed notification!
(when (gethash id unconsumed-notifications) ; Must have exited for reasons unrelated to notification
(remhash id unconsumed-notifications) ; Have to pass on the notification to an eligible waiter
(do-notify-single condition-variable)))))))
(mp:process-lock lock-))
t)
(define-condition-wait-compiler-macro)

143
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-lispworks.lisp Normal file
View file

@ -0,0 +1,143 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the LispWorks Multiprocessing interface can be found at
;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm
(deftype thread ()
'mp:process)
;;; Thread Creation
(defun start-multiprocessing ()
(mp:initialize-multiprocessing))
(defun %make-thread (function name)
(mp:process-run-function
name nil
(lambda ()
(let ((return-values
(multiple-value-list (funcall function))))
(setf (mp:process-property 'return-values)
return-values)
(values-list return-values)))))
(defun current-thread ()
#-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
mp:*current-process*
;; introduced in LispWorks 5.1
#+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or))
(mp:get-current-process))
(defun threadp (object)
(mp:process-p object))
(defun thread-name (thread)
(mp:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mp:lock)
#-(or lispworks4 lispworks5)
(deftype recursive-lock ()
'(and mp:lock (satisfies mp:lock-recursive-p)))
(defun lock-p (object)
(typep object 'mp:lock))
(defun recursive-lock-p (object)
#+(or lispworks4 lispworks5)
nil
#-(or lispworks4 lispworks5) ; version 6+
(and (typep object 'mp:lock)
(mp:lock-recursive-p object)))
(defun make-lock (&optional name)
(mp:make-lock :name (or name "Anonymous lock")
#-(or lispworks4 lispworks5) :recursivep
#-(or lispworks4 lispworks5) nil))
(defun acquire-lock (lock &optional (wait-p t))
(mp:process-lock lock nil
(cond ((null wait-p) 0)
((numberp wait-p) wait-p)
(t nil))))
(defun release-lock (lock)
(mp:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mp:make-lock :name (or name "Anonymous recursive lock")
#-(or lispworks4 lispworks5) :recursivep
#-(or lispworks4 lispworks5) t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(acquire-lock lock wait-p))
(defun release-recursive-lock (lock)
(release-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mp:with-lock (,place) ,@body))
;;; Resource contention: condition variables
#+(or lispworks6 lispworks7)
(defun make-condition-variable (&key name)
(mp:make-condition-variable :name (or name "Anonymous condition variable")))
#+(or lispworks6 lispworks7)
(defun condition-wait (condition-variable lock &key timeout)
(mp:condition-variable-wait condition-variable lock :timeout timeout)
t)
#+(or lispworks6 lispworks7)
(defun condition-notify (condition-variable)
(mp:condition-variable-signal condition-variable))
(defun thread-yield ()
(mp:process-allow-scheduling))
;;; Introspection/debugging
(defun all-threads ()
(mp:list-all-processes))
(defun interrupt-thread (thread function &rest args)
(apply #'mp:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mp:process-kill thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(declaim (inline %join-thread))
(defun %join-thread (thread)
#-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(complement #'mp:process-alive-p)
thread)
#+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
(mp:process-join thread))
(defun join-thread (thread)
(%join-thread thread)
(let ((return-values
(mp:process-property 'return-values thread)))
(values-list return-values)))
(mark-supported)

68
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-mcl.lisp Normal file
View file

@ -0,0 +1,68 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'ccl::process)
;;; Thread Creation
(defun %make-thread (function name)
(ccl:process-run-function name function))
(defun current-thread ()
ccl:*current-process*)
(defun threadp (object)
(ccl::processp object))
(defun thread-name (thread)
(ccl:process-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'ccl:lock)
(defun lock-p (object)
(typep object 'ccl:lock))
(defun make-lock (&optional name)
(ccl:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(if wait-p
(ccl:process-lock lock ccl:*current-process*)
;; this is broken, but it's better than a no-op
(ccl:without-interrupts
(when (null (ccl::lock.value lock))
(ccl:process-lock lock ccl:*current-process*)))))
(defun release-lock (lock)
(ccl:process-unlock lock))
(defmacro with-lock-held ((place) &body body)
`(ccl:with-lock-grabbed (,place) ,@body))
(defun thread-yield ()
(ccl:process-allow-schedule))
;;; Introspection/debugging
(defun all-threads ()
ccl:*all-processes*)
(defun interrupt-thread (thread function &rest args)
(declare (dynamic-extent args))
(apply #'ccl:process-interrupt thread function args))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(ccl:process-kill thread))
(mark-supported)

109
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-mkcl.lisp Normal file
View file

@ -0,0 +1,109 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Copyright 2010 Jean-Claude Beaudoin.
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'mt:thread)
;;; Thread Creation
(defun %make-thread (function name)
(mt:thread-run-function name function))
(defun current-thread ()
mt::*thread*)
(defun threadp (object)
(typep object 'mt:thread))
(defun thread-name (thread)
(mt:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'mt:lock)
(deftype recursive-lock ()
'(and mt:lock (satisfies mt:recursive-lock-p)))
(defun lock-p (object)
(typep object 'mt:lock))
(defun recursive-lock-p (object)
(and (typep object 'mt:lock)
(mt:recursive-lock-p object)))
(defun make-lock (&optional name)
(mt:make-lock :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(mt:get-lock lock wait-p))
(defun release-lock (lock)
(mt:giveup-lock lock))
(defmacro with-lock-held ((place) &body body)
`(mt:with-lock (,place) ,@body))
(defun make-recursive-lock (&optional name)
(mt:make-lock :name (or name "Anonymous recursive lock") :recursive t))
(defun acquire-recursive-lock (lock &optional (wait-p t))
(mt:get-lock lock wait-p))
(defun release-recursive-lock (lock)
(mt:giveup-lock lock))
(defmacro with-recursive-lock-held ((place) &body body)
`(mt:with-lock (,place) ,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(declare (ignore name))
(mt:make-condition-variable))
(defun condition-wait (condition-variable lock &key timeout)
(signal-error-if-condition-wait-timeout timeout)
(mt:condition-wait condition-variable lock)
t)
(define-condition-wait-compiler-macro)
(defun condition-notify (condition-variable)
(mt:condition-signal condition-variable))
(defun thread-yield ()
(mt:thread-yield))
;;; Introspection/debugging
(defun all-threads ()
(mt:all-threads))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(mt:interrupt-thread thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(mt:thread-kill thread))
(defun thread-alive-p (thread)
(mt:thread-active-p thread))
(defun join-thread (thread)
(mt:thread-join thread))
(mark-supported)

3
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-null.lisp Normal file
View file

@ -0,0 +1,3 @@
;;;; -*- indent-tabs-mode: nil -*-
(in-package #:bordeaux-threads)

130
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-sbcl.lisp Normal file
View file

@ -0,0 +1,130 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2006, 2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
;;; documentation on the SBCL Threads interface can be found at
;;; http://www.sbcl.org/manual/Threading.html
(deftype thread ()
'sb-thread:thread)
;;; Thread Creation
(defun %make-thread (function name)
(sb-thread:make-thread function :name name))
(defun current-thread ()
sb-thread:*current-thread*)
(defun threadp (object)
(typep object 'sb-thread:thread))
(defun thread-name (thread)
(sb-thread:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'sb-thread:mutex)
(deftype recursive-lock () 'sb-thread:mutex)
(defun lock-p (object)
(typep object 'sb-thread:mutex))
(defun recursive-lock-p (object)
(typep object 'sb-thread:mutex))
(defun make-lock (&optional name)
(sb-thread:make-mutex :name (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
#+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
(sb-thread:grab-mutex lock :waitp wait-p)
#-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))
(sb-thread:get-mutex lock nil wait-p))
(defun release-lock (lock)
(sb-thread:release-mutex lock))
(defmacro with-lock-held ((place) &body body)
`(sb-thread:with-mutex (,place) ,@body))
(defun make-recursive-lock (&optional name)
(sb-thread:make-mutex :name (or name "Anonymous recursive lock")))
;;; XXX acquire-recursive-lock and release-recursive-lock are actually
;;; complicated because we can't use control stack tricks. We need to
;;; actually count something to check that the acquire/releases are
;;; balanced
(defmacro with-recursive-lock-held ((place) &body body)
`(sb-thread:with-recursive-lock (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(sb-thread:make-waitqueue :name (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(sb-thread:condition-wait condition-variable lock :timeout timeout))
(defun condition-notify (condition-variable)
(sb-thread:condition-notify condition-variable))
(defun thread-yield ()
(sb-thread:release-foreground))
;;; Timeouts
(deftype timeout ()
'sb-ext:timeout)
(defmacro with-timeout ((timeout) &body body)
`(sb-ext:with-timeout ,timeout
,@body))
;;; Semaphores
(deftype semaphore ()
'sb-thread:semaphore)
(defun make-semaphore (&key name (count 0))
(sb-thread:make-semaphore :name name :count count))
(defun signal-semaphore (semaphore &key (count 1))
(sb-thread:signal-semaphore semaphore count))
(defun wait-on-semaphore (semaphore &key timeout)
(sb-thread:wait-on-semaphore semaphore :timeout timeout))
;;; Introspection/debugging
(defun all-threads ()
(sb-thread:list-all-threads))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(sb-thread:interrupt-thread thread (apply-function))))
(defun destroy-thread (thread)
(signal-error-if-current-thread thread)
(sb-thread:terminate-thread thread))
(defun thread-alive-p (thread)
(sb-thread:thread-alive-p thread))
(defun join-thread (thread)
(sb-thread:join-thread thread))
(mark-supported)

103
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-scl.lisp Normal file
View file

@ -0,0 +1,103 @@
;;;; -*- indent-tabs-mode: nil -*-
#|
Copyright 2008 Scieneer Pty Ltd
Distributed under the MIT license (see LICENSE file)
|#
(in-package #:bordeaux-threads)
(deftype thread ()
'thread:thread)
(defun %make-thread (function name)
(thread:thread-create function :name name))
(defun current-thread ()
thread:*thread*)
(defun threadp (object)
(typep object 'thread:thread))
(defun thread-name (thread)
(thread:thread-name thread))
;;; Resource contention: locks and recursive locks
(deftype lock () 'thread:lock)
(deftype recursive-lock () 'thread:recursive-lock)
(defun lock-p (object)
(typep object 'thread:lock))
(defun recursive-lock-p (object)
(typep object 'thread:recursive-lock))
(defun make-lock (&optional name)
(thread:make-lock (or name "Anonymous lock")))
(defun acquire-lock (lock &optional (wait-p t))
(thread::acquire-lock lock nil wait-p))
(defun release-lock (lock)
(thread::release-lock lock))
(defmacro with-lock-held ((place) &body body)
`(thread:with-lock-held (,place) ,@body))
(defun make-recursive-lock (&optional name)
(thread:make-lock (or name "Anonymous recursive lock")
:type :recursive))
;;; XXX acquire-recursive-lock and release-recursive-lock are actually
;;; complicated because we can't use control stack tricks. We need to
;;; actually count something to check that the acquire/releases are
;;; balanced
(defmacro with-recursive-lock-held ((place) &body body)
`(thread:with-lock-held (,place)
,@body))
;;; Resource contention: condition variables
(defun make-condition-variable (&key name)
(thread:make-cond-var (or name "Anonymous condition variable")))
(defun condition-wait (condition-variable lock &key timeout)
(if timeout
(thread:cond-var-timedwait condition-variable lock timeout)
(thread:cond-var-wait condition-variable lock))
t)
(defun condition-notify (condition-variable)
(thread:cond-var-broadcast condition-variable))
(defun thread-yield ()
(mp:process-yield))
;;; Introspection/debugging
(defun all-threads ()
(mp:all-processes))
(defun interrupt-thread (thread function &rest args)
(flet ((apply-function ()
(if args
(lambda () (apply function args))
function)))
(declare (dynamic-extent #'apply-function))
(thread:thread-interrupt thread (apply-function))))
(defun destroy-thread (thread)
(thread:destroy-thread thread))
(defun thread-alive-p (thread)
(mp:process-alive-p thread))
(defun join-thread (thread)
(mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
(lambda () (not (mp:process-alive-p thread)))))
(mark-supported)

66
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/pkgdcl.lisp Normal file
View file

@ -0,0 +1,66 @@
;;;; -*- indent-tabs-mode: nil -*-
(cl:defpackage :bordeaux-threads
(:nicknames #:bt)
(:use #:cl #:alexandria)
#+abcl
(:import-from :java #:jnew #:jcall #:jmethod)
(:export #:thread #:make-thread #:current-thread #:threadp #:thread-name
#:start-multiprocessing
#:*default-special-bindings* #:*standard-io-bindings*
#:*supports-threads-p*
#:lock #:make-lock #:lock-p
#:acquire-lock #:release-lock #:with-lock-held
#:recursive-lock #:make-recursive-lock #:recursive-lock-p
#:acquire-recursive-lock #:release-recursive-lock #:with-recursive-lock-held
#:make-condition-variable #:condition-wait #:condition-notify
#:make-semaphore #:signal-semaphore #:wait-on-semaphore #:semaphore #:semaphore-p
#:with-timeout #:timeout
#:all-threads #:interrupt-thread #:destroy-thread #:thread-alive-p
#:join-thread #:thread-yield)
(:documentation "BORDEAUX-THREADS is a proposed standard for a minimal
MP/threading interface. It is similar to the CLIM-SYS threading and
lock support, but for the following broad differences:
1) Some behaviours are defined in additional detail: attention has
been given to special variable interaction, whether and when
cleanup forms are run. Some behaviours are defined in less
detail: an implementation that does not support multiple
threads is not required to use a new list (nil) for a lock, for
example.
2) Many functions which would be difficult, dangerous or inefficient
to provide on some implementations have been removed. Chiefly
these are functions such as thread-wait which expect for
efficiency that the thread scheduler is written in Lisp and
'hookable', which can't sensibly be done if the scheduler is
external to the Lisp image, or the system has more than one CPU.
3) Unbalanced ACQUIRE-LOCK and RELEASE-LOCK functions have been
added.
4) Posix-style condition variables have been added, as it's not
otherwise possible to implement them correctly using the other
operations that are specified.
Threads may be implemented using whatever applicable techniques are
provided by the operating system: user-space scheduling,
kernel-based LWPs or anything else that does the job.
Some parts of this specification can also be implemented in a Lisp
that does not support multiple threads. Thread creation and some
thread inspection operations will not work, but the locking
functions are still present (though they may do nothing) so that
thread-safe code can be compiled on both multithread and
single-thread implementations without need of conditionals.
To avoid conflict with existing MP/threading interfaces in
implementations, these symbols live in the BORDEAUX-THREADS package.
Implementations and/or users may also make them visible or exported
in other more traditionally named packages."))

251
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/test/bordeaux-threads-test.lisp Normal file
View file

@ -0,0 +1,251 @@
#|
Copyright 2006,2007 Greg Pfeil
Distributed under the MIT license (see LICENSE file)
|#
(defpackage bordeaux-threads/test
(:use #:cl #:bordeaux-threads #:fiveam)
(:shadow #:with-timeout))
(in-package #:bordeaux-threads/test)
(def-suite :bordeaux-threads)
(def-fixture using-lock ()
(let ((lock (make-lock)))
(&body)))
(in-suite :bordeaux-threads)
(test should-have-current-thread
(is (current-thread)))
(test current-thread-identity
(let* ((box (list nil))
(thread (make-thread (lambda ()
(setf (car box) (current-thread))))))
(join-thread thread)
(is (eql (car box) thread))))
(test join-thread-return-value
(is (eql 0 (join-thread (make-thread (lambda () 0))))))
(test should-identify-threads-correctly
(is (threadp (current-thread)))
(is (threadp (make-thread (lambda () t) :name "foo")))
(is (not (threadp (make-lock)))))
(test should-retrieve-thread-name
(is (equal "foo" (thread-name (make-thread (lambda () t) :name "foo")))))
(test interrupt-thread
(let* ((box (list nil))
(thread (make-thread (lambda ()
(setf (car box)
(catch 'new-thread
(sleep 60)
'not-interrupted))))))
(sleep 1)
(interrupt-thread thread (lambda ()
(throw 'new-thread 'interrupted)))
(join-thread thread)
(is (eql 'interrupted (car box)))))
(test should-lock-without-contention
(with-fixture using-lock ()
(is (acquire-lock lock t))
(release-lock lock)
(is (acquire-lock lock nil))
(release-lock lock)))
(defun set-equal (set-a set-b)
(and (null (set-difference set-a set-b))
(null (set-difference set-b set-a))))
(test default-special-bindings
(locally (declare (special *a* *c*))
(let* ((the-as 50) (the-bs 150) (*b* 42)
some-a some-b some-other-a some-other-b
(*default-special-bindings*
`((*a* . (funcall ,(lambda () (incf the-as))))
(*b* . (funcall ,(lambda () (incf the-bs))))
,@*default-special-bindings*))
(threads (list (make-thread
(lambda ()
(setf some-a *a* some-b *b*)))
(make-thread
(lambda ()
(setf some-other-a *a*
some-other-b *b*))))))
(declare (special *b*))
(thread-yield)
(is (not (boundp '*a*)))
(loop while (some #'thread-alive-p threads)
do (thread-yield))
(is (set-equal (list some-a some-other-a) '(51 52)))
(is (set-equal (list some-b some-other-b) '(151 152)))
(is (not (boundp '*a*))))))
(defparameter *shared* 0)
(defparameter *lock* (make-lock))
(test should-have-thread-interaction
;; this simple test generates N process. Each process grabs and
;; releases the lock until SHARED has some value, it then
;; increments SHARED. the outer code first sets shared 1 which
;; gets the thing running and then waits for SHARED to reach some
;; value. this should, i think, stress test locks.
(setf *shared* 0)
(flet ((worker (i)
(loop
do (with-lock-held (*lock*)
(when (= i *shared*)
(incf *shared*)
(return)))
(thread-yield)
(sleep 0.001))))
(let* ((procs (loop
for i from 1 upto 2
;; create a new binding to protect against implementations that
;; mutate instead of binding the loop variable
collect (let ((i i))
(make-thread (lambda ()
(funcall #'worker i))
:name (format nil "Proc #~D" i))))))
(with-lock-held (*lock*)
(incf *shared*))
(block test
(loop
until (with-lock-held (*lock*)
(= (1+ (length procs)) *shared*))
do (with-lock-held (*lock*)
(is (>= (1+ (length procs)) *shared*)))
(thread-yield)
(sleep 0.001))))))
(defparameter *condition-variable* (make-condition-variable))
(test condition-variable
(setf *shared* 0)
(flet ((worker (i)
(with-lock-held (*lock*)
(loop
until (= i *shared*)
do (condition-wait *condition-variable* *lock*))
(incf *shared*))
(condition-notify *condition-variable*)))
(let ((num-procs 100))
(dotimes (i num-procs)
;; create a new binding to protect against implementations that
;; mutate instead of binding the loop variable
(let ((i i))
(make-thread (lambda ()
(funcall #'worker i))
:name (format nil "Proc #~D" i))))
(with-lock-held (*lock*)
(loop
until (= num-procs *shared*)
do (condition-wait *condition-variable* *lock*)))
(is (equal num-procs *shared*)))))
;; Generally safe sanity check for the locks and single-notify
#+(and lispworks (not lispworks6))
(test condition-variable-lw
(let ((condition-variable (make-condition-variable :name "Test"))
(test-lock (make-lock))
(completed nil))
(dotimes (id 6)
(let ((id id))
(make-thread (lambda ()
(with-lock-held (test-lock)
(condition-wait condition-variable test-lock)
(push id completed)
(condition-notify condition-variable))))))
(sleep 2)
(if completed
(print "Failed: Premature passage through condition-wait")
(print "Successfully waited on condition"))
(condition-notify condition-variable)
(sleep 2)
(if (and completed
(eql (length completed) 6)
(equal (sort completed #'<)
(loop for id from 0 to 5 collect id)))
(print "Success: All elements notified")
(print (format nil "Failed: Of 6 expected elements, only ~A proceeded" completed)))
(bt::with-cv-access condition-variable
(if (and
(not (or (car wait-tlist) (cdr wait-tlist)))
(zerop (hash-table-count wait-hash))
(zerop (hash-table-count unconsumed-notifications)))
(print "Success: condition variable restored to initial state")
(print "Error: condition variable retains residue from completed waiters")))
(setq completed nil)
(dotimes (id 6)
(let ((id id))
(make-thread (lambda ()
(with-lock-held (test-lock)
(condition-wait condition-variable test-lock)
(push id completed))))))
(sleep 2)
(condition-notify condition-variable)
(sleep 2)
(if (= (length completed) 1)
(print "Success: Notify-single only notified a single waiter to restart")
(format t "Failure: Notify-single restarted ~A items" (length completed)))
(condition-notify condition-variable)
(sleep 2)
(if (= (length completed) 2)
(print "Success: second Notify-single only notified a single waiter to restart")
(format t "Failure: Two Notify-singles restarted ~A items" (length completed)))
(loop for i from 0 to 5 do (condition-notify condition-variable))
(print "Note: In the case of any failures, assume there are outstanding waiting threads")
(values)))
#+(or abcl allegro clisp clozure ecl lispworks6 sbcl scl)
(test condition-wait-timeout
(let ((lock (make-lock))
(cvar (make-condition-variable))
(flag nil))
(make-thread (lambda () (sleep 0.4) (setf flag t)))
(with-lock-held (lock)
(condition-wait cvar lock :timeout 0.2)
(is (null flag))
(sleep 0.4)
(is (eq t flag)))))
(test semaphore-signal
(let ((sem (make-semaphore)))
(make-thread (lambda () (sleep 0.4) (signal-semaphore sem)))
(is (not (null (wait-on-semaphore sem))))))
(test semaphore-signal-n-of-m
(let* ((sem (make-semaphore :count 1))
(lock (make-lock))
(count 0)
(waiter (lambda ()
(wait-on-semaphore sem)
(with-lock-held (lock) (incf count)))))
(make-thread (lambda () (sleep 0.2) (signal-semaphore sem :count 3)))
(dotimes (v 5) (make-thread waiter))
(sleep 0.3)
(is (= count 4))
;; release other waiters
(signal-semaphore sem :count 10)
(sleep 0.1)
(is (= count 5))))
(test semaphore-wait-timeout
(let ((sem (make-semaphore))
(flag nil))
(make-thread (lambda () (sleep 0.4) (setf flag t)))
(is (null (wait-on-semaphore sem :timeout 0.2)))
(is (null flag))
(sleep 0.4)
(is (eq t flag))))
(test semaphore-typed
(is (typep (bt:make-semaphore) 'bt:semaphore))
(is (bt:semaphore-p (bt:make-semaphore)))
(is (null (bt:semaphore-p (bt:make-lock)))))

2
sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/version.sexp Normal file
View file

@ -0,0 +1,2 @@
;; -*- lisp -*-
"0.8.7"

28
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/.gitignore vendored Normal file
View file

@ -0,0 +1,28 @@
*~
*.o
*.dylib
*.dll
*.bundle
*.so
*.fasl
*.xfasl
.DS_Store
doc/*.aux
doc/manual/
doc/spec/
doc/*.log
doc/*.info
doc/*.aux
doc/*.cp
doc/*.fn
doc/*.fns
doc/*.ky
doc/*.pg
doc/*.toc
doc/*.tps
doc/*.tp
doc/*.vr
doc/*.dvi
doc/*.cps
doc/*.vrs
doc/dir

38
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/.travis.yml Normal file
View file

@ -0,0 +1,38 @@
branches:
only:
- master
language: lisp
env:
matrix:
#- LISP=abcl
#- LISP=allegro
- LISP=sbcl
- LISP=sbcl32
- LISP=ccl
- LISP=ccl32
#- LISP=clisp
#- LISP=clisp32
#- LISP=cmucl
#- LISP=ecl
matrix:
allow_failures:
- env: LISP=ccl32
install:
- curl -L https://github.com/luismbo/cl-travis/raw/master/install.sh | sh
- if [ "${LISP:(-2)}" = "32" ]; then
sudo apt-get install -y libc6-dev-i386 libffi-dev:i386;
fi
- git clone --depth=1 git://github.com/trivial-features/trivial-features.git ~/lisp/trivial-features
- git clone https://gitlab.common-lisp.net/alexandria/alexandria.git ~/lisp/alexandria
- git clone --depth=1 git://github.com/cl-babel/babel.git ~/lisp/babel
script:
- cl -e '(ql:quickload :cffi-tests)
(when (cffi-tests:run-all-cffi-tests)
(uiop:quit 1))'
sudo: required

21
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/COPYRIGHT Normal file
View file

@ -0,0 +1,21 @@
Copyright (C) 2005-2007, James Bielman <jamesjb@jamesjb.com>
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use, copy,
modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.

28
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/HEADER Normal file
View file

@ -0,0 +1,28 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; filename --- description
;;;
;;; Copyright (C) 2007, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;

72
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/Makefile Normal file
View file

@ -0,0 +1,72 @@
# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for various tasks.
#
# Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#
# This way you can easily run the tests for different versions
# of each lisp with, e.g. ALLEGRO=/path/to/some/lisp make test-allegro
CMUCL ?= lisp
OPENMCL ?= openmcl
SBCL ?= sbcl
CLISP ?= clisp
ALLEGRO ?= alisp
SCL ?= scl
ECL ?= ecl
shlibs:
@$(MAKE) -wC tests shlibs
clean:
@$(MAKE) -wC tests clean
find . -name ".fasls" | xargs rm -rf
find . \( -name "*.dfsl" -o -name "*.fasl" -o -name "*.fas" -o -name "*.lib" -o -name "*.x86f" -o -name "*.amd64f" -o -name "*.sparcf" -o -name "*.sparc64f" -o -name "*.hpf" -o -name "*.hp64f" -o -name "*.ppcf" -o -name "*.nfasl" -o -name "*.ufsl" -o -name "*.fsl" -o -name "*.lx64fsl" \) -exec rm {} \;
test-openmcl:
@-$(OPENMCL) --load tests/run-tests.lisp
test-sbcl:
@-$(SBCL) --noinform --load tests/run-tests.lisp
test-cmucl:
@-$(CMUCL) -load tests/run-tests.lisp
test-scl:
@-$(SCL) -load tests/run-tests.lisp
test-clisp:
@-$(CLISP) -q -x '(load "tests/run-tests.lisp")'
test-clisp-modern:
@-$(CLISP) -modern -q -x '(load "tests/run-tests.lisp")'
test-allegro:
@-$(ALLEGRO) -L tests/run-tests.lisp
test-ecl:
@-$(ECL) --quiet --load tests/run-tests.lisp
test: test-openmcl test-sbcl test-cmucl test-clisp test-ecl
# vim: ft=make ts=3 noet

19
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/README.md Normal file
View file

@ -0,0 +1,19 @@
[![Build Status](https://travis-ci.org/cffi/cffi.svg?branch=master)](https://travis-ci.org/cffi/cffi)
CFFI, the Common Foreign Function Interface, purports to be a portable
foreign function interface for Common Lisp. The CFFI library is
composed of a Lisp-implementation-specific backend in the CFFI-SYS
package, and a portable frontend in the CFFI package.
The CFFI-SYS backend package defines a low-level interface to the
native FFI support in the Lisp implementation. It offers operators for
allocating and dereferencing foreign memory, calling foreign
functions, and loading shared libraries. The CFFI frontend provides a
declarative interface for defining foreign functions, structures,
typedefs, enumerated types, etc. It is implemented in portable ANSI CL
making use of the low-level operators exported by CFFI-SYS.
Please consult [the manual][1] for further details, including
installation instructions.
[1]: http://common-lisp.net/project/cffi/manual/html_node/

115
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/TODO Normal file
View file

@ -0,0 +1,115 @@
-*- Text -*-
This is a collection of TODO items and ideas in no particular order.
### Testing
-> Test uffi-compat with more UFFI libraries.
-> Write more FOREIGN-GLOBALS.SET.* tests.
-> Finish tests/random-tester.lisp
-> Write benchmarks comparing CFFI vs. native FFIs and also demonstrating
performance of each platform.
-> Write more STRUCT.ALIGNMENT.* tests (namely involving the :LONG-LONG
and :UNSIGNED-LONG-LONG types) and test them in more ABIs.
-> Run tests with the different kinds of shared libraries available on
MacOS X.
### Ports
-> Finish GCL port, port to MCL.
-> Update Corman port. [2007-02-22 LO]
### Features
-> Implement a declarative interface for FOREIGN-FUNCALL-PTR, similar to
DEFCUN/FOREIGN-FUNCALL.
-> Implement the proposed interfaces (see doc/).
-> Extend FOREIGN-SLOT-VALUE and make it accept multiple "indices" for
directly accessing structs inside structs, arrays inside structs, etc...
-> Implement EXPLAIN-FOREIGN-SLOT-VALUE.
-> Implement :in/:out/:in-out for DEFCFUN (and FOREIGN-FUNCALL?).
-> Add support for multiple memory allocation schemes (like CLISP), namely
support for allocating with malloc() (so that it can be freed on the C
side)>
-> Extend DEFCVAR's symbol macro in order to handle memory (de)allocation
automatically (see CLISP).
-> Implement byte swapping routines (see /usr/include/linux/byteorder)
-> Warn about :void in places where it doesn't make sense.
### Underspecified Semantics
-> (setf (mem-ref ptr <aggregate-type> offset) <value>)
-> Review the interface for coherence across Lisps with regard to
behaviour in "exceptional" situations. Eg: threads, dumping cores,
accessing foreign symbols that don't exist, etc...
-> On Lispworks a Lisp float is a double and therefore won't necessarily
fit in a C float. Figure out a way to handle this.
-> Allegro: callbacks' return values.
-> Lack of uniformity with regard to pointers. Allegro: 0 -> NULL.
CLISP/Lispworks: NIL -> NULL.
-> Some lisps will accept a lisp float being passed to :double
and a lisp double to :float. We should either coerce on lisps that
don't accept this or check-type on lisps that do. Probably the former
is better since on lispworks/x86 double == float.
### Possible Optimizations
-> More compiler macros on some of the CFFI-SYS implementations.
-> Optimize UFFI-COMPAT when the vector stuff is implemented.
-> Being able to declare that some C int will always fit in a Lisp
fixnum. Allegro has a :fixnum ftype and CMUCL/SBCL can use
(unsigned-byte 29) others could perhaps behave like :int?
-> An option for defcfun to expand into a compiler macro which would
allow the macroexpansion-time translators to look at the forms
passed to the functions.
### Known Issues
-> CLISP FASL portability is broken. Fix this by placing LOAD-TIME-VALUE
forms in the right places and moving other calculations to load-time.
(eg: calculating struct size/alignment.) Ideally we'd only move them
to load-time when we actually care about fasl portability.
(defmacro maybe-load-time-value (form)
(if <we care about fasl portability>
`(load-time-value ,form)
form))
-> cffi-tests.asd's :c-test-lib component is causing the whole testsuite
to be recompiled everytime. Figure that out.
-> The (if (constantp foo) (do-something-with (eval foo)) ...) pattern
used in many places throughout the code is apparently not 100% safe.
-> On ECL platforms without DFFI we need to build a non-linked version
of libtest.
-> foreign-enum-keyword/value should have their own error condition?
<http://article.gmane.org/gmane.lisp.cffi.devel/975> [2007-02-22 LO]
### Documentation
-> Fill the missing sections in the CFFI User Manual.
-> Update the CFFI-SYS Specification.
-> have two versions of the manual on the website
### CFFI-Grovel
-> Look into making the C output more concise.
### CFFI-Toolchain
-> Port the toolchain parameter detection to more implementations
-> Port the static linking support to more implementations
-> Add a mechanism to configure and/or detect dynamic libraries against
which to link for instance.
It could be a variable in which flags are accumulated,
or an autodetection after loading everything, see
https://github.com/borodust/cl-bodge/blob/0.3.0/distribution/build.lisp#L79
### CFFI/C2FFI
-> Generate wrappers for C inline function definitions (and maybe for some
#define's?)
-> It would be nice if c2ffi emitted its output in a stable order
for details see https://github.com/rpav/c2ffi/issues/28
-> Handle va_list. For now it's treated as any other argument.
### Other
-> Type-checking pointer interface.

37
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-examples.asd Normal file
View file

@ -0,0 +1,37 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-examples.asd --- ASDF system definition for CFFI examples.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(defsystem cffi-examples
:description "CFFI Examples"
:author "James Bielman <jamesjb@jamesjb.com>"
:components
((:module examples
:components
((:file "examples")
(:file "gethostname")
(:file "gettimeofday"))))
:depends-on (cffi))

41
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-grovel.asd Normal file
View file

@ -0,0 +1,41 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-grovel.asd --- ASDF system definition for cffi-grovel.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(defsystem "cffi-grovel"
:description "The CFFI Groveller"
:author "Dan Knapp <dankna@accela.net>"
:depends-on ("cffi" "cffi-toolchain" "alexandria")
:licence "MIT"
:components
((:module "grovel"
:components
((:static-file "common.h")
(:file "package")
(:file "grovel" :depends-on ("package"))
(:file "asdf" :depends-on ("grovel"))))))
;; vim: ft=lisp et

48
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-libffi.asd Normal file
View file

@ -0,0 +1,48 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-libffi.asd --- Foreign Structures By Value
;;;
;;; Copyright (C) 2011 Liam M. Healy
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package :asdf)
(eval-when (:compile-toplevel :execute)
(asdf:oos 'asdf:load-op :cffi-grovel)
(asdf:oos 'asdf:load-op :trivial-features))
(defsystem cffi-libffi
:description "Foreign structures by value"
:author "Liam Healy <lhealy@common-lisp.net>"
:maintainer "Liam Healy <lhealy@common-lisp.net>"
:defsystem-depends-on (#:trivial-features #:cffi-grovel)
:components
((:module libffi
:serial t
:components
((:file "libffi")
(cffi-grovel:grovel-file "libffi-types")
(:file "libffi-functions")
(:file "type-descriptors")
(:file "funcall"))))
:depends-on (#:cffi #:cffi-grovel #:trivial-features))

91
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-tests.asd Normal file
View file

@ -0,0 +1,91 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-tests.asd --- ASDF system definition for CFFI unit tests.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2011, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(load-systems "trivial-features" "cffi-grovel")
(defclass c-test-lib (c-source-file)
())
(defmethod perform ((o load-op) (c c-test-lib))
nil)
(defmethod perform ((o load-source-op) (c c-test-lib))
nil)
(defmethod output-files ((o compile-op) (c c-test-lib))
(let ((p (component-pathname c)))
(values
(list (make-pathname :defaults p :type (asdf/bundle:bundle-pathname-type :object))
(make-pathname :defaults p :type (asdf/bundle:bundle-pathname-type :shared-library)))
t)))
(defmethod perform ((o compile-op) (c c-test-lib))
(let ((cffi-toolchain:*cc-flags* `(,@cffi-toolchain:*cc-flags* "-Wall" "-std=c99" "-pedantic")))
(destructuring-bind (obj dll) (output-files o c)
(cffi-toolchain:cc-compile obj (input-files o c))
(cffi-toolchain:link-shared-library dll (list obj)))))
(defsystem "cffi-tests"
:description "Unit tests for CFFI."
:depends-on ("cffi-grovel" "cffi-libffi" "bordeaux-threads" #-ecl "rt" #+ecl (:require "rt"))
:components
((:module "tests"
:components
((:c-test-lib "libtest")
(:c-test-lib "libtest2")
(:c-test-lib "libfsbv")
(:file "package")
(:file "bindings" :depends-on ("package" "libtest" "libtest2" "libfsbv"))
(:file "funcall" :depends-on ("bindings"))
(:file "defcfun" :depends-on ("bindings"))
(:file "callbacks" :depends-on ("bindings"))
(:file "foreign-globals" :depends-on ("package"))
(:file "memory" :depends-on ("package"))
(:file "strings" :depends-on ("package"))
(:file "arrays" :depends-on ("package"))
(:file "struct" :depends-on ("package"))
(:file "union" :depends-on ("package"))
(:file "enum" :depends-on ("package"))
(:file "fsbv" :depends-on ("bindings" "enum"))
(:file "misc-types" :depends-on ("bindings"))
(:file "misc" :depends-on ("bindings"))
(:file "test-asdf" :depends-on ("package"))
(:file "grovel" :depends-on ("package")))))
:perform (test-op (o c) (symbol-call :cffi-tests '#:run-all-cffi-tests)))
(defsystem "cffi-tests/example"
:defsystem-depends-on ("cffi-grovel")
:entry-point "cffi-example::entry-point"
:components
((:module "examples" :components
((:file "package")
(:cffi-wrapper-file "wrapper-example" :depends-on ("package"))
(:cffi-grovel-file "grovel-example" :depends-on ("package"))
(:file "main-example" :depends-on ("package"))))))
;;; vim: ft=lisp et

48
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-toolchain.asd Normal file
View file

@ -0,0 +1,48 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-toolchain.asd --- ASDF system definition for cffi-toolchain.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
;; Make sure to upgrade ASDF before the #.(if ...) below may be read.
(load-system "asdf")
#-asdf3.1 (error "CFFI-toolchain requires ASDF 3.1!")
(defsystem "cffi-toolchain"
:description "The CFFI toolchain"
:long-description "Portable abstractions for using the C compiler, linker, etc."
:author "Francois-Rene Rideau <fahree@gmail.com>"
:depends-on ((:version "asdf" "3.1.2") "cffi")
:licence "MIT"
:components
((:module "toolchain"
:components
(;; This is a plain copy of bundle.lisp from ASDF 3.2.0
;; in case your asdf isn't up to snuff.
(:file "bundle" :if-feature (#.(if (version< "3.1.8" (asdf-version)) :or :and)))
(:file "package")
(:file "c-toolchain" :depends-on ("package"))
(:file "static-link" :depends-on ("bundle" "c-toolchain"))))))
;; vim: ft=lisp et

41
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi-uffi-compat.asd Normal file
View file

@ -0,0 +1,41 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi-uffi-compat.asd --- ASDF system definition for CFFI-UFFI-COMPAT.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(defpackage #:cffi-uffi-compat-system
(:use #:cl #:asdf))
(in-package #:cffi-uffi-compat-system)
(defsystem cffi-uffi-compat
:description "UFFI Compatibility Layer for CFFI"
:author "James Bielman <jamesjb@jamesjb.com>"
:components
((:module uffi-compat
:components
((:file "uffi-compat"))))
:depends-on (cffi))
;; vim: ft=lisp et

101
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/cffi.asd Normal file
View file

@ -0,0 +1,101 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; cffi.asd --- ASDF system definition for CFFI.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2010, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package :asdf)
#-(or openmcl mcl sbcl cmucl scl clisp lispworks ecl allegro cormanlisp abcl mkcl clasp)
(error "Sorry, this Lisp is not yet supported. Patches welcome!")
(defsystem "cffi"
:description "The Common Foreign Function Interface"
:author "James Bielman <jamesjb@jamesjb.com>"
:maintainer "Luis Oliveira <loliveira@common-lisp.net>"
:licence "MIT"
:depends-on (:uiop :alexandria :trivial-features :babel)
:in-order-to ((test-op (load-op :cffi-tests)))
:perform (test-op (o c) (operate 'asdf:test-op :cffi-tests))
:components
((:module "src"
:serial t
:components
(#+openmcl (:file "cffi-openmcl")
#+mcl (:file "cffi-mcl")
#+sbcl (:file "cffi-sbcl")
#+cmucl (:file "cffi-cmucl")
#+scl (:file "cffi-scl")
#+clisp (:file "cffi-clisp")
#+lispworks (:file "cffi-lispworks")
#+ecl (:file "cffi-ecl")
#+allegro (:file "cffi-allegro")
#+cormanlisp (:file "cffi-corman")
#+abcl (:file "cffi-abcl")
#+mkcl (:file "cffi-mkcl")
#+clasp (:file "cffi-clasp")
(:file "package")
(:file "utils")
(:file "libraries")
(:file "early-types")
(:file "types")
(:file "enum")
(:file "strings")
(:file "structures")
(:file "functions")
(:file "foreign-vars")
(:file "features")))))
;; when you get CFFI from git, its defsystem doesn't have a version,
;; so we assume it satisfies any version requirements whatsoever.
(defmethod version-satisfies ((c (eql (find-system :cffi))) version)
(declare (ignorable version))
(or (null (component-version c))
(call-next-method)))
(defsystem "cffi/c2ffi"
:description "CFFI definition generator from the FFI spec generated by c2ffi. This system is enough to use the ASDF machinery (as a :defsystem-depends-on)."
:author "Attila Lendvai <attila@lendvai.name>"
:depends-on (:alexandria
:cffi)
:licence "MIT"
:components
((:module "src/c2ffi"
:components
((:file "package")
(:file "c2ffi" :depends-on ("package"))
(:file "asdf" :depends-on ("package" "c2ffi"))))))
(defsystem "cffi/c2ffi-generator"
:description "This system gets loaded lazily when the CFFI bindings need to be regenerated."
:author "Attila Lendvai <attila@lendvai.name>"
:depends-on (:cffi/c2ffi
:cl-ppcre
:cl-json)
:licence "MIT"
:components
((:module "src/c2ffi"
:components
((:file "generator")))))

46
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/Makefile Normal file
View file

@ -0,0 +1,46 @@
# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for generating the documentation.
#
# Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the "Software"), to deal in the Software without
# restriction, including without limitation the rights to use, copy,
# modify, merge, publish, distribute, sublicense, and/or sell copies
# of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
#
export LC_ALL=C
all: manual spec
manual: cffi-manual.texinfo style.css
sh gendocs.sh -o manual --html "--css-include=style.css" cffi-manual "CFFI User Manual"
spec: cffi-sys-spec.texinfo style.css
sh gendocs.sh -o spec --html "--css-include=style.css" cffi-sys-spec "CFFI-SYS Interface Specification"
clean:
find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \;
rm -rf manual spec dir
upload-docs: manual spec
rsync -av --delete -e ssh manual spec common-lisp.net:/project/cffi/public_html/
# scp -r manual spec common-lisp.net:/project/cffi/public_html/
# vim: ft=make ts=3 noet

132
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/allegro-internals.txt Normal file
View file

@ -0,0 +1,132 @@
July 2005
These details were kindly provided by Duane Rettig of Franz.
Regarding the following snippet of the macro expansion of
FF:DEF-FOREIGN-CALL:
(SYSTEM::FF-FUNCALL
(LOAD-TIME-VALUE (EXCL::DETERMINE-FOREIGN-ADDRESS
'("foo" :LANGUAGE :C) 2 NIL))
'(:INT (INTEGER * *)) ARG1
'(:DOUBLE (DOUBLE-FLOAT * *)) ARG2
'(:INT (INTEGER * *)))
"
... in Allegro CL, if you define a foreign call FOO with C entry point
"foo" and with :call-direct t in the arguments, and if other things are
satisfied, then if a lisp function BAR is compiled which has a call to
FOO, that call will not go through ff-funcall (and thus a large amount
of argument manipulation and processing) but will instead set up its
arguments directly on the stack, and will then perform the "call" more
or less directly, through the "entry vec" (a small structure which
keeps track of a foreign entry's address and status)."
This is the code that generates what the compiler expects to see:
(setq call-direct-form
(if* call-direct
then `(setf (get ',lispname 'sys::direct-ff-call)
(list ',external-name
,callback
,convention
',returning
',arg-types
,arg-checking
,entry-vec-flags))
else `(remprop ',lispname 'sys::direct-ff-call)))
Thus generating something like:
(EVAL-WHEN (COMPILE LOAD EVAL)
(SETF (GET 'FOO 'SYSTEM::DIRECT-FF-CALL)
(LIST '("foo" :LANGUAGE :C) T :C
'(:INT (INTEGER * *))
'((:INT (INTEGER * *))
(:FLOAT (SINGLE-FLOAT * *)))
T
2 ; this magic value is explained later
)))
"
(defun determine-foreign-address (name &optional (flags 0) method-index)
;; return an entry-vec struct suitable for the foreign-call of name.
;;
;; name is either a string, which is taken without conversion, or
;; a list consisting of a string to convert or a conversion function
;; call.
;; flags is an integer representing the flags to place into the entry-vec.
;; method-index, if non-nil, is a word-index into a vtbl (virtual table).
;; If method-index is true, then the name must be a string uniquely
;; represented by the index and by the flags field.
Note that not all architectures implement the :method-index argument
to def-foreign-call, but your interface likely won't support it
anyway, so just leave it nil. As for the flags, they are constants
stored into the entry-vec returned by d-f-a and are given here:
(defconstant ep-flag-call-semidirect 1) ; Real address stored in alt-address slot
(defconstant ep-flag-never-release 2) ; Never release the heap
(defconstant ep-flag-always-release 4) ; Always release the heap
(defconstant ep-flag-release-when-ok 8) ; Release the heap unless without-interrupts
(defconstant ep-flag-tramp-calls #x70) ; Make calls through special trampolines
(defconstant ep-flag-tramp-shift 4)
(defconstant ep-flag-variable-address #x100) ; Entry-point contains address of C var
(defconstant ep-flag-strings-convert #x200) ; Convert strings automatically
(defconstant ep-flag-get-errno #x1000) ;; [rfe5060]: Get errno value after call
(defconstant ep-flag-get-last-error #x2000) ;; [rfe5060]: call GetLastError after call
;; Leave #x4000 and #x8000 open for expansion
Mostly, you'll give the value 2 (never release the heap), but if you
give 4 or 8, then d-f-a will automatically set the 1 bit as well,
which takes the call through a heap-release/reacquire process.
Some docs for entry-vec are:
;; -- entry vec --
;; An entry-vec is an entry-point descriptor, usually a pointer into
;; a shared-library. It is represented as a 5-element struct of type
;; foreign-vector. The reason for this represntation is
;; that it allows the entry point to be stored in a table, called
;; the .saved-entry-points. table, and to be used by a foreign
;; function. When the location of the foreign function to which the entry
;; point refers changes, it is simply a matter of changing the value in entry
;; point vector and the foreign call code sees it immediately. There is
;; even an address that can be put in the entry point vector that denotes
;; a missing foreign function, thus lookup can happen dynamically.
(defstruct (entry-vec
(:type (vector excl::foreign (*)))
(:constructor make-entry-vec-boa ()))
name ; entry point name
(address 0) ; jump address for foreign code
(handle 0) ; shared-lib handle
(flags 0) ; ep-* flags
(alt-address 0) ; sometimes holds the real func addr
)
[...]
"
Regarding the arguments to SYSTEM::FF-FUNCALL:
'(:int (integer * *)) argN
"The type-spec is as it is given in the def-foreign-call
syntax, with a C type optionally followed by a lisp type,
followed optionally by a user-conversion function name[...]"
Getting the alignment:
CL-USER(2): (ff:get-foreign-type :int)
#S(FOREIGN-FUNCTIONS::IFOREIGN-TYPE
:ATTRIBUTES NIL
:SFTYPE
#S(FOREIGN-FUNCTIONS::SIZED-FTYPE-PRIM
:KIND :INT
:WIDTH 4
:OFFSET 0
:ALIGN 4)
...)

7113
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/cffi-manual.texinfo Normal file
View file

File diff suppressed because it is too large Load diff

334
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/cffi-sys-spec.texinfo Normal file
View file

@ -0,0 +1,334 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename cffi-sys.info
@settitle CFFI-SYS Interface Specification
@c Show types in the same index as the functions.
@synindex tp fn
@copying
Copyright @copyright{} 2005-2006, James Bielman <jamesjb at jamesjb.com>
@quotation
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the ``Software''), to deal in the Software without
restriction, including without limitation the rights to use, copy,
modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
@sc{The software is provided ``as is'', without warranty of any kind,
express or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and
noninfringement. In no event shall the authors or copyright
holders be liable for any claim, damages or other liability,
whether in an action of contract, tort or otherwise, arising from,
out of or in connection with the software or the use or other
dealings in the software.}
@end quotation
@end copying
@macro impnote {text}
@emph{Implementor's note: \text\}
@end macro
@c %**end of header
@dircategory Software development
@direntry
* CFFI Sys spec: (cffi-sys-spec). CFFI Sys spec.
@end direntry
@titlepage
@title CFFI-SYS Interface Specification
@c @subtitle Version X.X
@c @author James Bielman
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ifnottex
@node Top
@top cffi-sys
@insertcopying
@end ifnottex
@menu
* Introduction::
* Built-In Foreign Types::
* Operations on Foreign Types::
* Basic Pointer Operations::
* Foreign Memory Allocation::
* Memory Access::
* Foreign Function Calling::
* Loading Foreign Libraries::
* Foreign Globals::
* Symbol Index::
@end menu
@node Introduction
@chapter Introduction
@acronym{CFFI}, the Common Foreign Function Interface, purports to be
a portable foreign function interface for Common Lisp.
This specification defines a set of low-level primitives that must be
defined for each Lisp implementation supported by @acronym{CFFI}.
These operators are defined in the @code{CFFI-SYS} package.
The @code{CFFI} package uses the @code{CFFI-SYS} interface
to implement an extensible foreign type system with support for
typedefs, structures, and unions, a declarative interface for
defining foreign function calls, and automatic conversion of
foreign function arguments to/from Lisp types.
Please note the following conventions that apply to everything in
@code{CFFI-SYS}:
@itemize @bullet
@item
Functions in @code{CFFI-SYS} that are low-level versions of functions
exported from the @code{CFFI} package begin with a leading
percent-sign (eg. @code{%mem-ref}).
@item
Where ``foreign type'' is mentioned as the kind of an argument, the
meaning is restricted to that subset of all foreign types defined in
@ref{Built-In Foreign Types}. Support for higher-level types is
always defined in terms of those lower-level types in @code{CFFI}
proper.
@end itemize
@node Built-In Foreign Types
@chapter Built-In Foreign Types
@deftp {Foreign Type} :char
@deftpx {Foreign Type} :unsigned-char
@deftpx {Foreign Type} :short
@deftpx {Foreign Type} :unsigned-short
@deftpx {Foreign Type} :int
@deftpx {Foreign Type} :unsigned-int
@deftpx {Foreign Type} :long
@deftpx {Foreign Type} :unsigned-long
@deftpx {Foreign Type} :long-long
@deftpx {Foreign Type} :unsigned-long-long
These types correspond to the native C integer types according to the
ABI of the system the Lisp implementation is compiled against.
@end deftp
@deftp {Foreign Type} :int8
@deftpx {Foreign Type} :uint8
@deftpx {Foreign Type} :int16
@deftpx {Foreign Type} :uint16
@deftpx {Foreign Type} :int32
@deftpx {Foreign Type} :uint32
@deftpx {Foreign Type} :int64
@deftpx {Foreign Type} :uint64
Foreign integer types of specific sizes, corresponding to the C types
defined in @code{stdint.h}.
@end deftp
@deftp {Foreign Type} :size
@deftpx {Foreign Type} :ssize
@deftpx {Foreign Type} :ptrdiff
@deftpx {Foreign Type} :time
Foreign integer types corresponding to the standard C types (without
the @code{_t} suffix).
@end deftp
@impnote{I'm sure there are more of these that could be useful, let's
add any types that can't be defined portably to this list as
necessary.}
@deftp {Foreign Type} :float
@deftpx {Foreign Type} :double
The @code{:float} type represents a C @code{float} and a Lisp
@code{single-float}. @code{:double} represents a C @code{double} and a
Lisp @code{double-float}.
@end deftp
@deftp {Foreign Type} :pointer
A foreign pointer to an object of any type, corresponding to
@code{void *}.
@end deftp
@deftp {Foreign Type} :void
No type at all. Only valid as the return type of a function.
@end deftp
@node Operations on Foreign Types
@chapter Operations on Built-in Foreign Types
@defun %foreign-type-size type @result{} size
Return the @var{size}, in bytes, of objects having foreign type
@var{type}. An error is signalled if @var{type} is not a known
built-in foreign type.
@end defun
@defun %foreign-type-alignment type @result{} alignment
Return the default alignment in bytes for structure members of foreign
type @var{type}. An error is signalled if @var{type} is not a known
built-in foreign type.
@impnote{Maybe this should take an optional keyword argument specifying an
alternate alignment system, eg. :mac68k for 68000-compatible alignment
on Darwin.}
@end defun
@node Basic Pointer Operations
@chapter Basic Pointer Operations
@defun pointerp ptr @result{} boolean
Return true if @var{ptr} is a foreign pointer.
@end defun
@defun null-pointer @result{} pointer
Return a null foreign pointer.
@end defun
@defun null-pointer-p ptr @result{} boolean
Return true if @var{ptr} is a null foreign pointer.
@end defun
@defun make-pointer address @result{} pointer
Return a pointer corresponding to the numeric integer @var{address}.
@end defun
@defun inc-pointer ptr offset @result{} pointer
Return the result of numerically incrementing @var{ptr} by @var{offset}.
@end defun
@node Foreign Memory Allocation
@chapter Foreign Memory Allocation
@defun foreign-alloc size @result{} pointer
Allocate @var{size} bytes of foreign-addressable memory and return
a @var{pointer} to the allocated block. An implementation-specific
error is signalled if the memory cannot be allocated.
@end defun
@defun foreign-free ptr @result{} unspecified
Free a pointer @var{ptr} allocated by @code{foreign-alloc}. The
results are undefined if @var{ptr} is used after being freed.
@end defun
@defmac with-foreign-pointer (var size &optional size-var) &body body
Bind @var{var} to a pointer to @var{size} bytes of
foreign-accessible memory during @var{body}. Both @var{ptr} and the
memory block it points to have dynamic extent and may be stack
allocated if supported by the implementation. If @var{size-var} is
supplied, it will be bound to @var{size} during @var{body}.
@end defmac
@node Memory Access
@chapter Memory Access
@deffn {Accessor} %mem-ref ptr type &optional offset
Dereference a pointer @var{offset} bytes from @var{ptr} to an object
for reading (or writing when used with @code{setf}) of built-in type
@var{type}.
@end deffn
@heading Example
@lisp
;; An impractical example, since time returns the time as well,
;; but it demonstrates %MEM-REF. Better (simple) examples wanted!
(with-foreign-pointer (p (foreign-type-size :time))
(foreign-funcall "time" :pointer p :time)
(%mem-ref p :time))
@end lisp
@node Foreign Function Calling
@chapter Foreign Function Calling
@defmac %foreign-funcall name @{arg-type arg@}* &optional result-type @result{} object
@defmacx %foreign-funcall-pointer ptr @{arg-type arg@}* &optional result-type @result{} object
Invoke a foreign function called @var{name} in the foreign source code.
Each @var{arg-type} is a foreign type specifier, followed by
@var{arg}, Lisp data to be converted to foreign data of type
@var{arg-type}. @var{result-type} is the foreign type of the
function's return value, and is assumed to be @code{:void} if not
supplied.
@code{%foreign-funcall-pointer} takes a pointer @var{ptr} to the
function, as returned by @code{foreign-symbol-pointer}, rather than a
string @var{name}.
@end defmac
@defmac %foreign-funcall-varargs name (@{fixed-type arg@}*) @{vararg-type arg@}* &optional result-type @result{} object
@defmacx %foreign-funcall-varargs-pointer ptr (@{fixed-type arg@}*) @{vararg-type arg@}* &optional result-type @result{} object
Invoke a foreign variadic function called @var{name} in the foreign
source code.
Each @var{fixed-type} and @var{vararg-type} is a foreign type
specifier, followed by @var{arg}, Lisp data to be converted to foreign
data of type @var{arg-type}. @var{result-type} is the foreign type of
the function's return value, and is assumed to be @code{:void} if not
supplied.
@code{%foreign-funcall-pointer-varargs} takes a pointer @var{ptr} to
the variadic function, as returned by @code{foreign-symbol-pointer},
rather than a string @var{name}.
Both functions have default implementation which call
@code{%foreign-funcall} and @code{%foreign-funcall-pointer}
approprietly.
@end defmac
@heading Examples
@lisp
;; Calling a standard C library function:
(%foreign-funcall "sqrtf" :float 16.0 :float) @result{} 4.0
@end lisp
@lisp
;; Dynamic allocation of a buffer and passing to a function:
(with-foreign-ptr (buf 255 buf-size)
(%foreign-funcall "gethostname" :pointer buf :size buf-size :int)
;; Convert buf to a Lisp string using MAKE-STRING and %MEM-REF or
;; a portable CFFI function such as CFFI:FOREIGN-STRING-TO-LISP.
)
@end lisp
@node Loading Foreign Libraries
@chapter Loading Foreign Libraries
@defun %load-foreign-library name @result{} unspecified
Load the foreign shared library @var{name}.
@impnote{There is a lot of behavior to decide here. Currently I lean
toward not requiring NAME to be a full path to the library so
we can search the system library directories (maybe even get
LD_LIBRARY_PATH from the environment) as necessary.}
@end defun
@node Foreign Globals
@chapter Foreign Globals
@defun foreign-symbol-pointer name @result{} pointer
Return a pointer to a foreign symbol @var{name}.
@end defun
@node Symbol Index
@unnumbered Symbol Index
@printindex fn
@bye

1058
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/colorize-lisp-examples.lisp Normal file
View file

File diff suppressed because it is too large Load diff

313
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/gendocs.sh Normal file
View file

@ -0,0 +1,313 @@
#!/bin/sh
# gendocs.sh -- generate a GNU manual in many formats. This script is
# mentioned in maintain.texi. See the help message below for usage details.
# $Id: gendocs.sh,v 1.16 2005/05/15 00:00:08 karl Exp $
#
# Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, you can either send email to this
# program's maintainer or write to: The Free Software Foundation,
# Inc.; 51 Franklin Street, Fifth Floor; Boston, MA 02110-1301, USA.
#
# Original author: Mohit Agarwal.
# Send bug reports and any other correspondence to bug-texinfo@gnu.org.
#set -e
prog="`basename \"$0\"`"
srcdir=`pwd`
scripturl="https://github.com/cffi/cffi/blob/master/doc/gendocs.sh"
templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template"
: ${MAKEINFO="makeinfo"}
: ${TEXI2DVI="texi2dvi -t @finalout"}
: ${DVIPS="dvips"}
: ${DOCBOOK2TXT="docbook2txt"}
: ${DOCBOOK2HTML="docbook2html"}
: ${DOCBOOK2PDF="docbook2pdf"}
: ${DOCBOOK2PS="docbook2ps"}
: ${GENDOCS_TEMPLATE_DIR="."}
unset CDPATH
rcs_revision='$Revision: 1.16 $'
rcs_version=`set - $rcs_revision; echo $2`
program=`echo $0 | sed -e 's!.*/!!'`
version="gendocs.sh $rcs_version
Copyright (C) 2005 Free Software Foundation, Inc.
There is NO warranty. You may redistribute this software
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING."
usage="Usage: $prog [OPTION]... PACKAGE MANUAL-TITLE
Generate various output formats from PACKAGE.texinfo (or .texi or .txi) source.
See the GNU Maintainers document for a more extensive discussion:
http://www.gnu.org/prep/maintain_toc.html
Options:
-o OUTDIR write files into OUTDIR, instead of manual/.
--docbook convert to DocBook too (xml, txt, html, pdf and ps).
--html ARG pass indicated ARG to makeinfo for HTML targets.
--help display this help and exit successfully.
--version display version information and exit successfully.
Simple example: $prog emacs \"GNU Emacs Manual\"
Typical sequence:
cd YOURPACKAGESOURCE/doc
wget \"$scripturl\"
wget \"$templateurl\"
$prog YOURMANUAL \"GNU YOURMANUAL - One-line description\"
Output will be in a new subdirectory \"manual\" (by default, use -o OUTDIR
to override). Move all the new files into your web CVS tree, as
explained in the Web Pages node of maintain.texi.
MANUAL-TITLE is included as part of the HTML <title> of the overall
manual/index.html file. It should include the name of the package being
documented. manual/index.html is created by substitution from the file
$GENDOCS_TEMPLATE_DIR/gendocs_template. (Feel free to modify the
generic template for your own purposes.)
If you have several manuals, you'll need to run this script several
times with different YOURMANUAL values, specifying a different output
directory with -o each time. Then write (by hand) an overall index.html
with links to them all.
You can set the environment variables MAKEINFO, TEXI2DVI, and DVIPS to
control the programs that get executed, and GENDOCS_TEMPLATE_DIR to
control where the gendocs_template file is looked for.
Email bug reports or enhancement requests to bug-texinfo@gnu.org.
"
calcsize()
{
size="`ls -ksl $1 | awk '{print $1}'`"
echo $size
}
outdir=manual
html=
PACKAGE=
MANUAL_TITLE=
while test $# -gt 0; do
case $1 in
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
-o) shift; outdir=$1;;
--docbook) docbook=yes;;
--html) shift; html=$1;;
-*)
echo "$0: Unknown or ambiguous option \`$1'." >&2
echo "$0: Try \`--help' for more information." >&2
exit 1;;
*)
if test -z "$PACKAGE"; then
PACKAGE=$1
elif test -z "$MANUAL_TITLE"; then
MANUAL_TITLE=$1
else
echo "$0: extra non-option argument \`$1'." >&2
exit 1
fi;;
esac
shift
done
if test -s $srcdir/$PACKAGE.texinfo; then
srcfile=$srcdir/$PACKAGE.texinfo
elif test -s $srcdir/$PACKAGE.texi; then
srcfile=$srcdir/$PACKAGE.texi
elif test -s $srcdir/$PACKAGE.txi; then
srcfile=$srcdir/$PACKAGE.txi
else
echo "$0: cannot find .texinfo or .texi or .txi for $PACKAGE in $srcdir." >&2
exit 1
fi
if test ! -r $GENDOCS_TEMPLATE_DIR/gendocs_template; then
echo "$0: cannot read $GENDOCS_TEMPLATE_DIR/gendocs_template." >&2
echo "$0: it is available from $templateurl." >&2
exit 1
fi
echo Generating output formats for $srcfile
cmd="${MAKEINFO} -o $PACKAGE.info $srcfile"
echo "Generating info files... ($cmd)"
eval $cmd
install-info $PACKAGE.info dir
mkdir -p $outdir/
tar czf $outdir/$PACKAGE.info.tar.gz $PACKAGE.info*
info_tgz_size="`calcsize $outdir/$PACKAGE.info.tar.gz`"
# do not mv the info files, there's no point in having them available
# separately on the web.
cmd="${TEXI2DVI} $srcfile"
echo "Generating dvi ... ($cmd)"
eval $cmd
# now, before we compress dvi:
echo Generating postscript...
${DVIPS} $PACKAGE -o
gzip -f -9 $PACKAGE.ps
ps_gz_size="`calcsize $PACKAGE.ps.gz`"
mv $PACKAGE.ps.gz $outdir/
# compress/finish dvi:
gzip -f -9 $PACKAGE.dvi
dvi_gz_size="`calcsize $PACKAGE.dvi.gz`"
mv $PACKAGE.dvi.gz $outdir/
cmd="${TEXI2DVI} --pdf $srcfile"
echo "Generating pdf ... ($cmd)"
eval $cmd
pdf_size="`calcsize $PACKAGE.pdf`"
mv $PACKAGE.pdf $outdir/
cmd="${MAKEINFO} -o $PACKAGE.txt --no-split --no-headers $srcfile"
echo "Generating ASCII... ($cmd)"
eval $cmd
ascii_size="`calcsize $PACKAGE.txt`"
gzip -f -9 -c $PACKAGE.txt >$outdir/$PACKAGE.txt.gz
ascii_gz_size="`calcsize $outdir/$PACKAGE.txt.gz`"
mv $PACKAGE.txt $outdir/
# Print a SED expression that will translate references to MANUAL to
# the proper page on gnu.org. This is a horrible shell hack done
# because \| in sed regexps is a GNU extension.
monognuorg () {
case "$1" in
libtool) echo "s!$1.html!http://www.gnu.org/software/$1/manual.html!" ;;
*) echo "s!$1.html!http://www.gnu.org/software/$1/manual/html_mono/$1.html!" ;;
esac
}
polygnuorg () {
case "$1" in
libtool) echo 's!\.\./'"$1/.*\.html!http://www.gnu.org/software/$1/manual.html!" ;;
*) echo 's!\.\./'"$1!http://www.gnu.org/software/$1/manual/html_node!" ;;
esac
}
cmd="${MAKEINFO} --no-split --html -o $PACKAGE.html $html $srcfile"
echo "Generating monolithic html... ($cmd)"
rm -rf $PACKAGE.html # in case a directory is left over
eval $cmd
sbcl --no-sysinit --no-userinit --load colorize-lisp-examples.lisp $PACKAGE.html
#fix libc/libtool xrefs
sed -e `monognuorg libc` -e `monognuorg libtool` $PACKAGE.html >$outdir/$PACKAGE.html
rm $PACKAGE.html
html_mono_size="`calcsize $outdir/$PACKAGE.html`"
gzip -f -9 -c $outdir/$PACKAGE.html >$outdir/$PACKAGE.html.gz
html_mono_gz_size="`calcsize $outdir/$PACKAGE.html.gz`"
cmd="${MAKEINFO} --html -o $PACKAGE.html $html $srcfile"
echo "Generating html by node... ($cmd)"
eval $cmd
split_html_dir=$PACKAGE.html
sbcl --no-userinit --no-sysinit --load colorize-lisp-examples.lisp "${split_html_dir}"/\*.html
(
cd ${split_html_dir} || exit 1
#fix libc xrefs
for broken_file in *.html; do
sed -e `polygnuorg libc` -e `polygnuorg libtool` "$broken_file" > "$broken_file".temp
mv -f "$broken_file".temp "$broken_file"
done
tar -czf ../$outdir/${PACKAGE}.html_node.tar.gz -- *.html
)
html_node_tgz_size="`calcsize $outdir/${PACKAGE}.html_node.tar.gz`"
rm -f $outdir/html_node/*.html
mkdir -p $outdir/html_node/
mv ${split_html_dir}/*.html $outdir/html_node/
rmdir ${split_html_dir}
echo Making .tar.gz for sources...
srcfiles=`ls *.texinfo *.texi *.txi *.eps 2>/dev/null`
tar cvzfh $outdir/$PACKAGE.texi.tar.gz $srcfiles
texi_tgz_size="`calcsize $outdir/$PACKAGE.texi.tar.gz`"
if test -n "$docbook"; then
cmd="${MAKEINFO} -o - --docbook $srcfile > ${srcdir}/$PACKAGE-db.xml"
echo "Generating docbook XML... $(cmd)"
eval $cmd
docbook_xml_size="`calcsize $PACKAGE-db.xml`"
gzip -f -9 -c $PACKAGE-db.xml >$outdir/$PACKAGE-db.xml.gz
docbook_xml_gz_size="`calcsize $outdir/$PACKAGE-db.xml.gz`"
mv $PACKAGE-db.xml $outdir/
cmd="${DOCBOOK2HTML} -o $split_html_db_dir ${outdir}/$PACKAGE-db.xml"
echo "Generating docbook HTML... ($cmd)"
eval $cmd
split_html_db_dir=html_node_db
(
cd ${split_html_db_dir} || exit 1
tar -czf ../$outdir/${PACKAGE}.html_node_db.tar.gz -- *.html
)
html_node_db_tgz_size="`calcsize $outdir/${PACKAGE}.html_node_db.tar.gz`"
rm -f $outdir/html_node_db/*.html
mkdir -p $outdir/html_node_db
mv ${split_html_db_dir}/*.html $outdir/html_node_db/
rmdir ${split_html_db_dir}
cmd="${DOCBOOK2TXT} ${outdir}/$PACKAGE-db.xml"
echo "Generating docbook ASCII... ($cmd)"
eval $cmd
docbook_ascii_size="`calcsize $PACKAGE-db.txt`"
mv $PACKAGE-db.txt $outdir/
cmd="${DOCBOOK2PS} ${outdir}/$PACKAGE-db.xml"
echo "Generating docbook PS... $(cmd)"
eval $cmd
gzip -f -9 -c $PACKAGE-db.ps >$outdir/$PACKAGE-db.ps.gz
docbook_ps_gz_size="`calcsize $outdir/$PACKAGE-db.ps.gz`"
mv $PACKAGE-db.ps $outdir/
cmd="${DOCBOOK2PDF} ${outdir}/$PACKAGE-db.xml"
echo "Generating docbook PDF... ($cmd)"
eval $cmd
docbook_pdf_size="`calcsize $PACKAGE-db.pdf`"
mv $PACKAGE-db.pdf $outdir/
fi
echo Writing index file...
curdate="`date '+%B %d, %Y'`"
sed \
-e "s!%%TITLE%%!$MANUAL_TITLE!g" \
-e "s!%%DATE%%!$curdate!g" \
-e "s!%%PACKAGE%%!$PACKAGE!g" \
-e "s!%%HTML_MONO_SIZE%%!$html_mono_size!g" \
-e "s!%%HTML_MONO_GZ_SIZE%%!$html_mono_gz_size!g" \
-e "s!%%HTML_NODE_TGZ_SIZE%%!$html_node_tgz_size!g" \
-e "s!%%INFO_TGZ_SIZE%%!$info_tgz_size!g" \
-e "s!%%DVI_GZ_SIZE%%!$dvi_gz_size!g" \
-e "s!%%PDF_SIZE%%!$pdf_size!g" \
-e "s!%%PS_GZ_SIZE%%!$ps_gz_size!g" \
-e "s!%%ASCII_SIZE%%!$ascii_size!g" \
-e "s!%%ASCII_GZ_SIZE%%!$ascii_gz_size!g" \
-e "s!%%TEXI_TGZ_SIZE%%!$texi_tgz_size!g" \
-e "s!%%DOCBOOK_HTML_NODE_TGZ_SIZE%%!$html_node_db_tgz_size!g" \
-e "s!%%DOCBOOK_ASCII_SIZE%%!$docbook_ascii_size!g" \
-e "s!%%DOCBOOK_PS_GZ_SIZE%%!$docbook_ps_gz_size!g" \
-e "s!%%DOCBOOK_PDF_SIZE%%!$docbook_pdf_size!g" \
-e "s!%%DOCBOOK_XML_SIZE%%!$docbook_xml_size!g" \
-e "s!%%DOCBOOK_XML_GZ_SIZE%%!$docbook_xml_gz_size!g" \
-e "s,%%SCRIPTURL%%,$scripturl,g" \
-e "s!%%SCRIPTNAME%%!$prog!g" \
$GENDOCS_TEMPLATE_DIR/gendocs_template >$outdir/index.html
echo "Done! See $outdir/ subdirectory for new files."

259
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/gendocs_template Normal file
View file

@ -0,0 +1,259 @@
<?xml version="1.0" encoding="utf-8" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<!-- $Id: gendocs_template,v 1.7 2005/05/15 00:00:08 karl Exp $ -->
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<!--
This template was adapted from Texinfo:
http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template
-->
<head>
<title>%%TITLE%%</title>
<meta http-equiv="content-type" content='text/html; charset=utf-8' />
<!-- <link rel="stylesheet" type="text/css" href="/gnu.css" /> -->
<!-- <link rev="made" href="webmasters@gnu.org" /> -->
<style>
/* CSS style taken from http://gnu.org/gnu.css */
html, body {
background-color: #FFFFFF;
color: #000000;
font-family: sans-serif;
}
a:link {
color: #1f00ff;
background-color: transparent;
text-decoration: underline;
}
a:visited {
color: #9900dd;
background-color: transparent;
text-decoration: underline;
}
a:hover {
color: #9900dd;
background-color: transparent;
text-decoration: none;
}
.center {
text-align: center;
}
.italic {
font-style: italic;
}
.bold {
font-weight: bold;
}
.quote {
margin-left: 40px;
margin-right: 40px;
}
.hrsmall {
width: 80px;
height: 1px;
margin-left: 20px;
}
.td_title {
border-color: #3366cc;
border-style: solid;
border-width: thin;
color: #3366cc;
background-color : #f2f2f9;
font-weight: bold;
}
.td_con {
padding-top: 3px;
padding-left: 8px;
padding-bottom: 3px;
color : #303030;
background-color : #fefefe;
font-size: smaller;
}
.translations {
background-color: transparent;
color: black;
font-family: serif;
font-size: smaller;
}
.fsflink {
font-size: smaller;
font-family: monospace;
color : #000000;
border-left: #3366cc thin solid;
border-bottom: #3366cc thin solid;
padding-left: 5px;
padding-bottom: 5px;
}
/*
* rtl stands for right-to-left layout, as in farsi/persian,
* arabic, etc. See also trans_rtl.
*/
.fsflink_rtl {
font-size: smaller;
font-family: monospace;
color : #000000;
border-right: #3366cc thin solid;
border-bottom: #3366cc thin solid;
padding-right: 5px;
padding-bottom: 5px;
}
.trans {
font-size: smaller;
color : #000000;
border-left: #3366cc thin solid;
padding-left: 20px;
}
.trans_rtl {
font-size: smaller;
color : #000000;
border-right: #3366cc thin solid;
padding-right: 20px;
}
img {
border: none 0;
}
td.side {
color: #3366cc;
/* background: #f2f2f9;
border-color: #3366cc;
border-style: solid;
border-width: thin; */
border-color: white;
border-style: none;
vertical-align: top;
width: 150px;
}
div.copyright {
font-size: 80%;
border: 2px solid #3366cc;
padding: 4px;
background: #f2f2f9;
border-style: solid;
border-width: thin;
}
.footnoteref {
font-size: smaller;
vertical-align: text-top;
}
</style>
</head>
<!-- This document is in XML, and xhtml 1.0 -->
<!-- Please make sure to properly nest your tags -->
<!-- and ensure that your final document validates -->
<!-- consistent with W3C xhtml 1.0 and CSS standards -->
<!-- See validator.w3.org -->
<body>
<h3>%%TITLE%%</h3>
<!-- <address>Free Software Foundation</address> -->
<address>last updated %%DATE%%</address>
<!--
<p>
<a href="/graphics/gnu-head.jpg">
<img src="/graphics/gnu-head-sm.jpg"
alt=" [image of the head of a GNU] "
width="129" height="122" />
</a>
<a href="/philosophy/gif.html">(no gifs due to patent problems)</a>
</p>
-->
<hr />
<p>This document <!--(%%PACKAGE%%)--> is available in the following formats:</p>
<ul>
<li><a href="%%PACKAGE%%.html">HTML
(%%HTML_MONO_SIZE%%K characters)</a> - entirely on one web page.</li>
<li><a href="html_node/index.html">HTML</a> - with one web page per
node.</li>
<li><a href="%%PACKAGE%%.html.gz">HTML compressed
(%%HTML_MONO_GZ_SIZE%%K gzipped characters)</a> - entirely on
one web page.</li>
<li><a href="%%PACKAGE%%.html_node.tar.gz">HTML compressed
(%%HTML_NODE_TGZ_SIZE%%K gzipped tar file)</a> -
with one web page per node.</li>
<li><a href="%%PACKAGE%%.info.tar.gz">Info document
(%%INFO_TGZ_SIZE%%K characters gzipped tar file)</a>.</li>
<li><a href="%%PACKAGE%%.txt">ASCII text
(%%ASCII_SIZE%%K characters)</a>.</li>
<li><a href="%%PACKAGE%%.txt.gz">ASCII text compressed
(%%ASCII_GZ_SIZE%%K gzipped characters)</a>.</li>
<li><a href="%%PACKAGE%%.dvi.gz">TeX dvi file
(%%DVI_GZ_SIZE%%K characters gzipped)</a>.</li>
<li><a href="%%PACKAGE%%.ps.gz">PostScript file
(%%PS_GZ_SIZE%%K characters gzipped)</a>.</li>
<li><a href="%%PACKAGE%%.pdf">PDF file
(%%PDF_SIZE%%K characters)</a>.</li>
<li><a href="%%PACKAGE%%.texi.tar.gz">Texinfo source
(%%TEXI_TGZ_SIZE%%K characters gzipped tar file)</a></li>
</ul>
<p>(This page was generated by the <a href="%%SCRIPTURL%%">%%SCRIPTNAME%%
script</a>.)</p>
<div class="copyright">
<p>
Return to <a href="/project/cffi/">CFFI's home page</a>.
</p>
<!--
<p>
Please send FSF &amp; GNU inquiries to
<a href="mailto:gnu@gnu.org"><em>gnu@gnu.org</em></a>.
There are also <a href="/home.html#ContactInfo">other ways to contact</a>
the FSF.
<br />
Please send broken links and other corrections (or suggestions) to
<a href="mailto:webmasters@gnu.org"><em>webmasters@gnu.org</em></a>.
</p>
-->
<p>
Copyright (C) 2005 James Bielman &lt;jamesjb at jamesjb.com&gt;<br />
Copyright (C) 2005 Lu&iacute;s Oliveira &lt;loliveira at common-lisp.net&gt;
<!--
<br />
Verbatim copying and distribution of this entire article is
permitted in any medium, provided this notice is preserved.
-->
</p>
<p>
Updated: %%DATE%%
<!-- timestamp start -->
<!-- $Date: 2005/05/15 00:00:08 $ $Author: karl $ -->
<!-- timestamp end -->
</p>
</div>
</body>
</html>

75
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/mem-vector.txt Normal file
View file

@ -0,0 +1,75 @@
# Block Memory Operations
Function: mem-fill ptr type count value &optional (offset 0)
Fill COUNT objects of TYPE, starting at PTR plus offset, with VALUE.
;; Equivalent to (but possibly more efficient than):
(loop for i below count
for off from offset by (%foreign-type-size type)
do (setf (%mem-ref ptr type off) value))
Function: mem-read-vector vector ptr type count &optional (offset 0)
Copy COUNT objects of TYPE from foreign memory at PTR plus OFFSET into
VECTOR. If VECTOR is not large enough to contain COUNT objects, it
will copy as many objects as necessary to fill the vector. The
results are undefined if the foreign memory block is not large enough
to supply the data to copy.
TYPE must be a built-in foreign type (integer, float, double, or
pointer).
Returns the number of objects copied.
;; Equivalent to (but possibly more efficient than):
(loop for i below (min count (length vector))
for off from offset by (%foreign-type-size type)
do (setf (aref vector i) (%mem-ref ptr type off))
finally (return i))
Function: mem-read-c-string string ptr &optional (offset 0)
Copy a null-terminated C string from PTR plus OFFSET into STRING, a
Lisp string. If STRING is not large enough to contain the data at PTR
it will be truncated.
Returns the number of characters copied into STRING.
;; Equivalent to (but possibly more efficient than):
(loop for i below (length string)
for off from offset
for char = (%mem-ref ptr :char off)
until (zerop char)
do (setf (char string i) char)
finally (return i))
Function: mem-write-vector vector ptr type &optional
(count (length vector)) (offset 0)
Copy COUNT objects from VECTOR into objects of TYPE in foreign memory,
starting at PTR plus OFFSET. The results are undefined if PTR does
not point to a memory block large enough to hold the data copied.
TYPE must be a built-in type (integer, float, double, or pointer).
Returns the number of objects copied from VECTOR to PTR.
;; Equivalent to (but possibly more efficient than):
(loop for i below count
for off from offset by (%foreign-type-size type)
do (setf (%mem-ref ptr type off) (aref vector i))
finally (return i))
Function: mem-write-c-string string ptr &optional (offset 0)
Copy the characters from a Lisp STRING to PTR plus OFFSET, adding a
final null terminator at the end. The results are undefined if the
memory at PTR is not large enough to accomodate the data.
This interface is currently equivalent to MEM-WRITE-VECTOR with a TYPE
of :CHAR, but will be useful when proper support for Unicode strings
is implemented.

44
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/shareable-vectors.txt Normal file
View file

@ -0,0 +1,44 @@
# Shareable Byte Vectors
Function: make-shareable-byte-vector size
Create a vector of element type (UNSIGNED-BYTE 8) suitable for passing
to WITH-POINTER-TO-VECTOR-DATA.
;; Minimal implementation:
(defun make-shareable-byte-vector (size)
(make-array size :element-type '(unsigned-byte 8)))
Macro: with-pointer-to-vector-data (ptr-var vector) &body body
Bind PTR-VAR to a pointer to the data contained in a shareable byte
vector.
VECTOR must be a shareable vector created by MAKE-SHAREABLE-BYTE-VECTOR.
PTR-VAR may point directly into the Lisp vector data, or it may point
to a temporary block of foreign memory which will be copied to and
from VECTOR.
Both the pointer object in PTR-VAR and the memory it points to have
dynamic extent. The results are undefined if foreign code attempts to
access this memory outside this dynamic contour.
The implementation must guarantee the memory pointed to by PTR-VAR
will not be moved during the dynamic contour of this operator, either
by creating the vector in a static area or temporarily disabling the
garbage collector.
;; Minimal (copying) implementation:
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
(let ((vector-var (gensym))
(size-var (gensym)))
`(let* ((,vector-var ,vector)
(,size-var (length ,vector-var)))
(with-foreign-ptr (,ptr-var ,size-var)
(mem-write-vector ,vector-var ,ptr :uint8)
(prog1
(progn ,@body)
(mem-read-vector ,vector-var ,ptr-var :uint8 ,size-var))))))

48
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/doc/style.css Normal file
View file

@ -0,0 +1,48 @@
body {font-family: Georgia, serif;
line-height: 1.3;
padding-left: 5em; padding-right: 1em;
padding-bottom: 1em; max-width: 60em;}
table {border-collapse: collapse}
span.roman { font-family: century schoolbook, serif; font-weight: normal; }
h1, h2, h3, h4, h5, h6 {font-family: Helvetica, sans-serif}
h4 { margin-top: 2.5em; }
dfn {font-family: inherit; font-variant: italic; font-weight: bolder }
kbd {font-family: monospace; text-decoration: underline}
/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/
var {font-variant: slanted;}
td {padding-right: 1em; padding-left: 1em}
sub {font-size: smaller}
.node {padding: 0; margin: 0}
pre.lisp { font-family: monospace;
background-color: #F4F4F4; border: 1px solid #AAA;
padding-top: 0.5em; padding-bottom: 0.5em; }
/* coloring */
.lisp-bg { background-color: #F4F4F4 ; color: black; }
.lisp-bg:hover { background-color: #F4F4F4 ; color: black; }
.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;}
a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; }
.special { font-weight: bold; color: #FF5000; background-color: inherit; }
.keyword { font-weight: bold; color: #770000; background-color: inherit; }
.comment { font-weight: normal; color: #007777; background-color: inherit; }
.string { font-weight: bold; color: #777777; background-color: inherit; }
.character { font-weight: bold; color: #0055AA; background-color: inherit; }
.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; }
span.paren1 { font-weight: bold; color: #777777; }
span.paren1:hover { color: #777777; background-color: #BAFFFF; }
span.paren2 { color: #777777; }
span.paren2:hover { color: #777777; background-color: #FFCACA; }
span.paren3 { color: #777777; }
span.paren3:hover { color: #777777; background-color: #FFFFBA; }
span.paren4 { color: #777777; }
span.paren4:hover { color: #777777; background-color: #CACAFF; }
span.paren5 { color: #777777; }
span.paren5:hover { color: #777777; background-color: #CAFFCA; }
span.paren6 { color: #777777; }
span.paren6:hover { color: #777777; background-color: #FFBAFF; }

Some files were not shown because too many files have changed in this diff Show more