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

Vim window logic, slimv

Browse source
This commit is contained in:
Ian Keane 2020-02-24 20:27:04 -05:00
parent babcc9e44b
commit 515847d07e
791 changed files with 51552 additions and 86 deletions
Download patch file Download diff file Expand all files Collapse all files

BIN
sbcl/.quicklisp/dists/quicklisp/archives/anaphora-20191007-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-ansi-text-20150804-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-colors-20180328-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-emb-20190521-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-fad-20190813-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-ppcre-20190521-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-project-20190521-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/html-template-20171227-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/let-plus-20191130-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/local-time-20190710-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/prove-20171130-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/quickproject-1.4.1.tgz Normal file
View file

Binary file not shown.

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/anaphora.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/anaphora-20191007-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-ansi-text.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ansi-text-20150804-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-colors.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-colors-20180328-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-emb.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-emb-20190521-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-fad.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-fad-20190813-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-ppcre.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ppcre-20190521-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/cl-project.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-project-20190521-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/html-template.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/html-template-20171227-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/let-plus.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/let-plus-20191130-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/local-time.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/local-time-20190710-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/prove.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/prove-20171130-git/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/quickproject.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/quickproject-1.4.1/

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/anaphora.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/anaphora-20191007-git/anaphora.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-ansi-text-test.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text-test.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-ansi-text.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-colors.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-colors-20180328-git/cl-colors.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-emb.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-emb-20190521-git/cl-emb.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-fad.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-fad-20190813-git/cl-fad.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-postgres+local-time.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/local-time-20190710-git/cl-postgres+local-time.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-ppcre-unicode.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ppcre-20190521-git/cl-ppcre-unicode.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-ppcre.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-ppcre-20190521-git/cl-ppcre.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-project-test.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-project-20190521-git/cl-project-test.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-project.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/cl-project-20190521-git/cl-project.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/cl-test-more.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/prove-20171130-git/cl-test-more.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/html-template.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/html-template-20171227-git/html-template.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/let-plus.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/let-plus-20191130-git/let-plus.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/local-time.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/local-time-20190710-git/local-time.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/prove-asdf.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/prove-20171130-git/prove-asdf.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/prove-test.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/prove-20171130-git/prove-test.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/prove.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/prove-20171130-git/prove.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/quickproject.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/quickproject-1.4.1/quickproject.asd

34
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/.travis.yml Normal file
View file

@ -0,0 +1,34 @@
language: lisp
sudo: required
env:
matrix:
- LISP=abcl
- LISP=allegro
- LISP=sbcl
- LISP=sbcl32
- LISP=ccl
- LISP=ccl32
- LISP=ecl
- LISP=clisp
- LISP=clisp32
- LISP=cmucl
matrix:
allow_failures:
# Disabled until issue #6 is fixed.
- env: LISP=clisp
- env: LISP=clisp32
# Disabled until cim supports cmucl.
- env: LISP=cmucl
install:
- curl -L https://github.com/tokenrove/cl-travis/raw/master/install.sh | sh
- if [ "${LISP:(-2)}" = "32" ]; then
sudo apt-get install -qq -y libc6-dev-i386;
fi
script:
- cl -e '(ql:quickload :anaphora/test)
(unless (asdf:oos :test-op :anaphora/test)
(uiop:quit 1))'

3
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/LICENSE Normal file
View file

@ -0,0 +1,3 @@
;;;; This file is part of the Anaphora package Common Lisp,
;;;; and has been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>

50
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/README.md Normal file
View file

@ -0,0 +1,50 @@
# Anaphora
Anaphora is the anaphoric macro collection from Hell: it includes many
new fiends in addition to old friends like `AIF` and `AWHEN`.
Anaphora has been placed in Public Domain by the author, [Nikodemus
Siivola](mailto:nikodemus@random-state.net).
# Installation
Use [quicklisp](http://www.quicklisp.org/), and simply:
```
CL-USER(1): (ql:quickload "anaphora")
```
# Documentation
Anaphoric macros provide implicit bindings for various
operations. Extensive use of anaphoric macros is not good style,
and probably makes you go blind as well — there's a reason why
Anaphora claims to be from Hell.
Anaphora provides two families of anaphoric macros, which can be
identified by their names and packages (both families are also
exported from the package `ANAPHORA`). The implicitly-bound symbol
`ANAPHORA:IT` is also exported from all three packages.
## Basic anaphora
#### Exported from package `ANAPHORA-BASIC`
These bind their first argument to `IT` via `LET`. In case of `COND`
all clauses have their test-values bound to `IT`.
Variants: `AAND`, `ALET`, `APROG1`, `AIF`, `ACOND`, `AWHEN`, `ACASE`,
`ACCASE`, `AECASE`, `ATYPECASE`, `ACTYPECASE`, and `AETYPECASE`.
## Symbol-macro anaphora
#### Exported from package `ANAPHORA-SYMBOL`
These bind their first argument (unevaluated) to `IT` via
SYMBOL-`MACROLET.`
Variants: `SOR`, `SLET`, `SIF`, `SCOND`, `SUNLESS`,
`SWHEN`, `SCASE`, `SCCASE`, `SECASE`, `STYPECASE`, `SCTYPECASE`,
`SETYPECASE`.
Also: `ASIF`, which binds via `LET` for the
then-clause, and `SYMBOL-MACROLET` for the else-clause.

31
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/anaphora.asd Normal file
View file

@ -0,0 +1,31 @@
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-lisp; -*-
;;;; Anaphora: The Anaphoric Macro Package from Hell
;;;;
;;;; This been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>
(defsystem :anaphora
:version "0.9.6"
:description "The Anaphoric Macro Package from Hell"
:author "Nikodemus Siivola <nikodemus@random-state.net>"
:license "Public Domain"
:components
((:file "packages")
(:file "early" :depends-on ("packages"))
(:file "symbolic" :depends-on ("early"))
(:file "anaphora" :depends-on ("symbolic"))))
(defsystem :anaphora/test
:description "Tests for anaphora"
:author "Nikodemus Siivola <nikodemus@random-state.net>"
:license "Public Domain"
:depends-on (:anaphora :rt)
:components ((:file "tests")))
(defmethod perform ((o test-op) (c (eql (find-system :anaphora))))
(test-system :anaphora/test))
(defmethod perform ((o test-op) (c (eql (find-system :anaphora/test))))
(or (symbol-call :rt '#:do-tests)
(error "test-op failed")))

162
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/anaphora.lisp Normal file
View file

@ -0,0 +1,162 @@
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
;;;; Anaphora: The Anaphoric Macro Package from Hell
;;;;
;;;; This been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>
(in-package :anaphora)
;;; This was the original implementation of SYMBOLIC -- and still good
;;; for getting the basic idea. Brian Masterbrooks solution to
;;; infinite recusion during macroexpansion, that nested forms of this
;;; are subject to, is in symbolic.lisp.
;;;
;;; (defmacro symbolic (op test &body body &environment env)
;;; `(symbol-macrolet ((it ,test))
;;; (,op it ,@body)))
(defmacro alet (form &body body)
"Binds the FORM to IT (via LET) in the scope of the BODY."
`(anaphoric ignore-first ,form (progn ,@body)))
(defmacro slet (form &body body)
"Binds the FORM to IT (via SYMBOL-MACROLET) in the scope of the BODY. IT can
be set with SETF."
`(symbolic ignore-first ,form (progn ,@body)))
(defmacro aand (first &rest rest)
"Like AND, except binds the first argument to IT (via LET) for the
scope of the rest of the arguments."
`(anaphoric and ,first ,@rest))
(defmacro sor (first &rest rest)
"Like OR, except binds the first argument to IT (via SYMBOL-MACROLET) for
the scope of the rest of the arguments. IT can be set with SETF."
`(symbolic or ,first ,@rest))
(defmacro aif (test then &optional else)
"Like IF, except binds the result of the test to IT (via LET) for
the scope of the then and else expressions."
`(anaphoric if ,test ,then ,else))
(defmacro sif (test then &optional else)
"Like IF, except binds the test form to IT (via SYMBOL-MACROLET) for
the scope of the then and else expressions. IT can be set with SETF"
`(symbolic if ,test ,then ,else))
(defmacro asif (test then &optional else)
"Like IF, except binds the result of the test to IT (via LET) for
the the scope of the then-expression, and the test form to IT (via
SYMBOL-MACROLET) for the scope of the else-expression. Within scope of
the else-expression, IT can be set with SETF."
`(let ((it ,test))
(if it
,then
(symbolic ignore-first ,test ,else))))
(defmacro aprog1 (first &body rest)
"Binds IT to the first form so that it can be used in the rest of the
forms. The whole thing returns IT."
`(anaphoric prog1 ,first ,@rest))
(defmacro awhen (test &body body)
"Like WHEN, except binds the result of the test to IT (via LET) for the scope
of the body."
`(anaphoric when ,test ,@body))
(defmacro swhen (test &body body)
"Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the
scope of the body. IT can be set with SETF."
`(symbolic when ,test ,@body))
(defmacro sunless (test &body body)
"Like UNLESS, except binds the test form to IT (via SYMBOL-MACROLET) for the
scope of the body. IT can be set with SETF."
`(symbolic unless ,test ,@body))
(defmacro acase (keyform &body cases)
"Like CASE, except binds the result of the keyform to IT (via LET) for the
scope of the cases."
`(anaphoric case ,keyform ,@cases))
(defmacro scase (keyform &body cases)
"Like CASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
scope of the body. IT can be set with SETF."
`(symbolic case ,keyform ,@cases))
(defmacro aecase (keyform &body cases)
"Like ECASE, except binds the result of the keyform to IT (via LET) for the
scope of the cases."
`(anaphoric ecase ,keyform ,@cases))
(defmacro secase (keyform &body cases)
"Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
scope of the cases. IT can be set with SETF."
`(symbolic ecase ,keyform ,@cases))
(defmacro accase (keyform &body cases)
"Like CCASE, except binds the result of the keyform to IT (via LET) for the
scope of the cases. Unlike CCASE, the keyform/place doesn't receive new values
possibly stored with STORE-VALUE restart; the new value is received by IT."
`(anaphoric ccase ,keyform ,@cases))
(defmacro sccase (keyform &body cases)
"Like CCASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
scope of the cases. IT can be set with SETF."
`(symbolic ccase ,keyform ,@cases))
(defmacro atypecase (keyform &body cases)
"Like TYPECASE, except binds the result of the keyform to IT (via LET) for
the scope of the cases."
`(anaphoric typecase ,keyform ,@cases))
(defmacro stypecase (keyform &body cases)
"Like TYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
scope of the cases. IT can be set with SETF."
`(symbolic typecase ,keyform ,@cases))
(defmacro aetypecase (keyform &body cases)
"Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
the scope of the cases."
`(anaphoric etypecase ,keyform ,@cases))
(defmacro setypecase (keyform &body cases)
"Like ETYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
the scope of the cases. IT can be set with SETF."
`(symbolic etypecase ,keyform ,@cases))
(defmacro actypecase (keyform &body cases)
"Like CTYPECASE, except binds the result of the keyform to IT (via LET) for
the scope of the cases. Unlike CTYPECASE, new values possible stored by the
STORE-VALUE restart are not received by the keyform/place, but by IT."
`(anaphoric ctypecase ,keyform ,@cases))
(defmacro sctypecase (keyform &body cases)
"Like CTYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
the scope of the cases. IT can be set with SETF."
`(symbolic ctypecase ,keyform ,@cases))
(defmacro acond (&body clauses)
"Like COND, except result of each test-form is bound to IT (via LET) for the
scope of the corresponding clause."
(labels ((rec (clauses)
(if clauses
(destructuring-bind ((test &body body) . rest) clauses
(if body
`(anaphoric if ,test (progn ,@body) ,(rec rest))
`(anaphoric if ,test it ,(rec rest))))
nil)))
(rec clauses)))
(defmacro scond (&body clauses)
"Like COND, except each test-form is bound to IT (via SYMBOL-MACROLET) for the
scope of the corresponsing clause. IT can be set with SETF."
(labels ((rec (clauses)
(if clauses
(destructuring-bind ((test &body body) . rest) clauses
(if body
`(symbolic if ,test (progn ,@body) ,(rec rest))
`(symbolic if ,test it ,(rec rest))))
nil)))
(rec clauses)))

20
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/early.lisp Normal file
View file

@ -0,0 +1,20 @@
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
;;;; Anaphora: The Anaphoric Macro Package from Hell
;;;;
;;;; This been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>
(in-package :anaphora)
(defmacro with-unique-names ((&rest bindings) &body body)
`(let ,(mapcar #'(lambda (binding)
(destructuring-bind (var prefix)
(if (consp binding) binding (list binding binding))
`(,var (gensym ,(string prefix)))))
bindings)
,@body))
(defmacro ignore-first (first expr)
(declare (ignore first))
expr)

90
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/packages.lisp Normal file
View file

@ -0,0 +1,90 @@
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-
;;;; Anaphora: The Anaphoric Macro Package from Hell
;;;;
;;;; This been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>
(defpackage :anaphora
(:use :cl)
(:export
#:it
#:alet
#:slet
#:aif
#:aand
#:sor
#:awhen
#:aprog1
#:acase
#:aecase
#:accase
#:atypecase
#:aetypecase
#:actypecase
#:acond
#:sif
#:asif
#:swhen
#:sunless
#:scase
#:secase
#:sccase
#:stypecase
#:setypecase
#:sctypecase
#:scond)
(:documentation
"ANAPHORA provides a full complement of anaphoric macros. Subsets of the
functionality provided by this package are exported from ANAPHORA-BASIC and
ANAPHORA-SYMBOL."))
(defpackage :anaphora-basic
(:use :cl :anaphora)
(:export
#:it
#:alet
#:aif
#:aand
#:awhen
#:aprog1
#:acase
#:aecase
#:accase
#:atypecase
#:aetypecase
#:actypecase
#:acond)
(:documentation
"ANAPHORA-BASIC provides all normal anaphoric constructs, which bind
primary values to IT."))
(defpackage :anaphora-symbol
(:use :cl :anaphora)
(:export
#:it
#:slet
#:sor
#:sif
#:asif
#:swhen
#:sunless
#:scase
#:secase
#:sccase
#:stypecase
#:setypecase
#:sctypecase
#:scond)
(:documentation
"ANAPHORA-SYMBOL provides ``symbolic anaphoric macros'', which bind forms
to IT via SYMBOL-MACROLET.
Examples:
(sor (gethash key table) (setf it default))
(asif (gethash key table)
(foo it) ; IT is a value bound by LET here
(setf it default)) ; IT is the GETHASH form bound by SYMBOL-MACROLET here
"))

54
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/symbolic.lisp Normal file
View file

@ -0,0 +1,54 @@
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
;;;; Copyright (c) 2003 Brian Mastenbrook
;;;; 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 :anaphora)
(defmacro internal-symbol-macrolet (&rest whatever)
`(symbol-macrolet ,@whatever))
(define-setf-expander internal-symbol-macrolet (binding-forms place &environment env)
(multiple-value-bind (dummies vals newvals setter getter)
(get-setf-expansion place env)
(values dummies
(substitute `(symbol-macrolet ,binding-forms it) 'it vals)
newvals
`(symbol-macrolet ,binding-forms ,setter)
`(symbol-macrolet ,binding-forms ,getter))))
(with-unique-names (s-indicator current-s-indicator)
(defmacro symbolic (operation test &rest other-args)
(with-unique-names (this-s)
(let ((current-s (get s-indicator current-s-indicator)))
(setf (get s-indicator current-s-indicator) this-s)
`(symbol-macrolet
((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test))
(it ,this-s))
(,operation it ,@other-args)))))
(defmacro anaphoric (op test &body body)
(with-unique-names (this-s)
(setf (get s-indicator current-s-indicator) this-s)
`(let* ((it ,test)
(,this-s it))
(declare (ignorable ,this-s))
(,op it ,@body)))))

427
sbcl/.quicklisp/dists/quicklisp/software/anaphora-20191007-git/tests.lisp Normal file
View file

@ -0,0 +1,427 @@
;;;; Anaphora: The Anaphoric Macro Package from Hell
;;;;
;;;; This been placed in Public Domain by the author,
;;;; Nikodemus Siivola <nikodemus@random-state.net>
(defpackage :anaphora-test
(:use :cl :anaphora :rt))
(in-package :anaphora-test)
(deftest alet.1
(alet (1+ 1)
(1+ it))
3)
(deftest alet.2
(alet (1+ 1)
it
(1+ it))
3)
(deftest slet.1
(let ((x (list 1 2 3)))
(slet (car x)
(incf it) (values it x)))
2 (2 2 3))
(deftest aand.1
(aand (+ 1 1)
(+ 1 it))
3)
(deftest aand.2
(aand 1 t (values it 2))
1 2)
(deftest aand.3
(let ((x 1))
(aand (incf x) t t (values t it)))
t 2)
(deftest aand.4
(aand 1 (values t it))
t 1)
#+(or)
;;; bug or a feature? forms like this expand to
;;;
;;; (let ((it (values ...))) (and it ...))
;;;
(deftest aand.5
(aand (values nil t) it)
nil t)
(deftest sor.1
(let ((x (list nil)))
(sor (car x)
(setf it t))
x)
(t))
(deftest aif.1
(aif (+ 1 1)
(+ 1 it)
:never)
3)
(deftest aif.2
(let ((x 0))
(aif (incf x)
it
:never))
1)
(deftest aif.3
(let ((x 0))
(aif (eval `(and ,(incf x) nil))
:never
(list it x)))
(nil 1))
(deftest sif.1
(let ((x (list nil)))
(sif (car x)
(setf it :oops)
(setf it :yes!))
(car x))
:yes!)
(deftest sif.2
(let ((x (list t)))
(sif (car x)
(setf it :yes!)
(setf it :oops))
(car x))
:yes!)
(deftest sif.3
(sif (list 1 2 3)
(sif (car it)
(setf it 'a)
:foo))
a)
(deftest sif.4
(progn
(defclass sif.4 ()
((a :initform (list :sif))))
(with-slots (a)
(make-instance 'sif.4)
(sif a
(sif (car it)
it))))
:sif)
(deftest asif.1
(let ((x (list 0)))
(asif (incf (car x))
it
(list :oops it)))
1)
(deftest asif.2
(let ((x (list nil)))
(asif (car x)
(setf x :oops)
(setf it :yes!))
x)
(:yes!))
(deftest awhen.1
(let ((x 0))
(awhen (incf x)
(+ 1 it)))
2)
(deftest awhen.2
(let ((x 0))
(or (awhen (not (incf x))
t)
x))
1)
(deftest swhen.1
(let ((x 0))
(swhen x
(setf it :ok))
x)
:ok)
(deftest swhen.2
(let ((x nil))
(swhen x
(setf it :oops))
x)
nil)
(deftest sunless.1
(let ((x nil))
(sunless x
(setf it :ok))
x)
:ok)
(deftest sunless.2
(let ((x t))
(sunless x
(setf it :oops))
x)
t)
(deftest acase.1
(let ((x 0))
(acase (incf x)
(0 :no)
(1 (list :yes it))
(2 :nono)))
(:yes 1))
(deftest scase.1
(let ((x (list 3)))
(scase (car x)
(0 (setf it :no))
(3 (setf it :yes!))
(t (setf it :nono)))
x)
(:yes!))
(deftest aecase.1
(let ((x (list :x)))
(aecase (car x)
(:y :no)
(:x (list it :yes))))
(:x :yes))
(deftest aecase.2
(nth-value 0 (ignore-errors
(let ((x (list :x)))
(secase (car x)
(:y :no)))
:oops))
nil)
(deftest secase.1
(let ((x (list :x)))
(secase (car x)
(:y (setf it :no))
(:x (setf it :yes)))
x)
(:yes))
(deftest secase.2
(nth-value 0 (ignore-errors
(let ((x (list :x)))
(secase (car x)
(:y (setf it :no)))
:oops)))
nil)
(deftest accase.1
(let ((x (list :x)))
(accase (car x)
(:y :no)
(:x (list it :yes))))
(:x :yes))
(deftest accase.2
(let ((x (list :x)))
(handler-bind ((type-error (lambda (e) (store-value :z e))))
(accase (car x)
(:y (setf x :no))
(:z (setf x :yes))))
x)
:yes)
(deftest accase.3
(let ((x (list :x)))
(accase (car x)
(:x (setf it :foo)))
x)
(:x))
(deftest sccase.1
(let ((x (list :x)))
(sccase (car x)
(:y (setf it :no))
(:x (setf it :yes)))
x)
(:yes))
(deftest sccase.2
(let ((x (list :x)))
(handler-bind ((type-error (lambda (e) (store-value :z e))))
(sccase (car x)
(:y (setf it :no))
(:z (setf it :yes))))
x)
(:yes))
(deftest atypecase.1
(atypecase 1.0
(integer (+ 2 it))
(float (1- it)))
0.0)
(deftest atypecase.2
(atypecase "Foo"
(fixnum :no)
(hash-table :nono))
nil)
(deftest stypecase.1
(let ((x (list 'foo)))
(stypecase (car x)
(vector (setf it :no))
(symbol (setf it :yes)))
x)
(:yes))
(deftest stypecase.2
(let ((x (list :bar)))
(stypecase (car x)
(fixnum (setf it :no)))
x)
(:bar))
(deftest aetypecase.1
(aetypecase 1.0
(fixnum (* 2 it))
(float (+ 2.0 it))
(symbol :oops))
3.0)
(deftest aetypecase.2
(nth-value 0 (ignore-errors
(aetypecase 1.0
(symbol :oops))))
nil)
(deftest setypecase.1
(let ((x (list "Foo")))
(setypecase (car x)
(symbol (setf it :no))
(string (setf it "OK"))
(integer (setf it :noon)))
x)
("OK"))
(deftest setypecase.2
(nth-value 0 (ignore-errors
(setypecase 'foo
(string :nono))))
nil)
(deftest actypecase.1
(actypecase :foo
(string (list :string it))
(keyword (list :keyword it))
(symbol (list :symbol it)))
(:keyword :foo))
(deftest actypecase.2
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
(actypecase 0
(string it)))
"OK")
(deftest sctypecase.1
(let ((x (list 0)))
(sctypecase (car x)
(symbol (setf it 'symbol))
(bit (setf it 'bit)))
x)
(bit))
(deftest sctypecase.2
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
(let ((x (list 0)))
(sctypecase (car x)
(string (setf it :ok)))
x))
(:ok))
(deftest acond.1
(acond (:foo))
:foo)
(deftest acond.2
(acond ((null 1) (list :no it))
((+ 1 2) (list :yes it))
(t :nono))
(:yes 3))
(deftest acond.3
(acond ((= 1 2) :no)
(nil :nono)
(t :yes))
:yes)
;; Test COND with multiple forms in the implicit progn.
(deftest acond.4
(let ((foo))
(acond ((+ 2 2) (setf foo 38) (incf foo it) foo)
(t nil)))
42)
(deftest scond.1
(let ((x (list nil))
(y (list t)))
(scond ((car x) (setf it :nono))
((car y) (setf it :yes)))
(values x y))
(nil)
(:yes))
(deftest scond.2
(scond ((= 1 2) :no!))
nil)
(deftest aprog.1
(aprog1 :yes
(unless (eql it :yes) (error "Broken."))
:no)
:yes)
(deftest aif.sif.1
(sif 1 (aif it it))
1)
(deftest aif.sif.2
(aif 1 (sif it it))
1)
(deftest aif.sif.3
(aif (list 1 2 3)
(sif (car it)
(setf it 'a)
:foo))
a)
(deftest alet.slet.1
(slet 42 (alet 43 (slet it it)))
43)
(defun elt-like (index seq)
(elt seq index))
(define-setf-expander elt-like (index seq)
(let ((index-var (gensym "index"))
(seq-var (gensym "seq"))
(store (gensym "store")))
(values (list index-var seq-var)
(list index seq)
(list store)
`(if (listp ,seq-var)
(setf (nth ,index-var ,seq-var) ,store)
(setf (aref ,seq-var ,index-var) ,store))
`(if (listp ,seq-var)
(nth ,index-var ,seq-var)
(aref ,seq-var ,index-var)))))
(deftest symbolic.setf-expansion.1
(let ((cell (list nil)))
(sor (elt-like 0 cell) (setf it 1))
(equal cell '(1)))
t)

13
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/.travis.yml Normal file
View file

@ -0,0 +1,13 @@
before_script:
- curl -O -L http://prdownloads.sourceforge.net/sbcl/sbcl-1.2.6-x86-64-linux-binary.tar.bz2
- tar xjf sbcl-1.2.6-x86-64-linux-binary.tar.bz2
- pushd sbcl-1.2.6-x86-64-linux/ && sudo bash install.sh && popd
- curl -O -L http://beta.quicklisp.org/quicklisp.lisp
- sbcl --load quicklisp.lisp --eval '(quicklisp-quickstart:install)' --eval '(quit)'
- curl -OL http://ccl.clozure.com/ftp/pub/release/1.10/ccl-1.10-linuxx86.tar.gz
- tar xzf ccl-1.10-linuxx86.tar.gz
- export PATH=`pwd`/ccl:$PATH
# - lx86cl64 -b --load quicklisp.lisp --eval '(progn (quicklisp-quickstart:install) (quit))'
script:
- ./ci-test-run.sh

140
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/README.md Normal file
View file

@ -0,0 +1,140 @@
# cl-ansi-text
Because color in your terminal is nice.
[![Build Status](https://travis-ci.org/pnathan/cl-ansi-text.svg?branch=master)](https://travis-ci.org/pnathan/cl-ansi-text)
## Usage example -
```lisp
* (ql:quickload :cl-ansi-text)
;To load "cl-ansi-text":
; Load 1 ASDF system:
; cl-ansi-text
;; Loading "cl-ansi-text"
; => (:CL-ANSI-TEXT)
```
The main macro is called `with-color`, which creates an enviroment where everything that is put on `stream` gets colored according to `color`. Color options are `:black`, `:red`, `:green`, `:yellow`, `:blue`, `:magenta`, `:cyan` and `:white`. You can also use a color structure from `CL-COLORS`, like `cl-colors:+red+`.
```lisp
* (import 'cl-ansi-text:with-color)
; => T
* (with-color (:red)
(princ "Gets printed red...")
(princ "and this too!"))
; Gets printed red...and this too!
; => "and this too!"
```
There are also functions with the name of the colors, that return the string, colored:
```lisp
* (import 'cl-ansi-text:yellow)
; => T
* (yellow "Yellow string")
; => "Yellow string"
* (princ (yellow "String with yellow background" :style :background))
; "String with yellow background"
; => "String with yellow background"
* (import 'cl-ansi-text:red)
; => T
* (princ
(concatenate
'string
(yellow "Five") " test results went " (red "terribly wrong") "!"))
; Five test results went terribly wrong!
; => "Five test results went terribly wrong!"
```
At any point, you can bind the `*enabled*` special variable to `nil`, and anything inside that binding will not be printed colorfully:
```lisp
* (let (cl-ansi-text:*enabled*)
(princ (red "This string is printed normally")))
```
# API
## BLUE
Returns a string with the `blue'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## MAGENTA
Returns a string with the `magenta'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## CYAN
Returns a string with the `cyan'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## GREEN
Returns a string with the `green'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## WITH-COLOR
Writes out the string denoting a switch to `color`, executes body,
then writes out the string denoting a `reset`.
*enabled* dynamically controls expansion..
## YELLOW
Returns a string with the `yellow'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## BLACK
Returns a string with the `black'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## *ENABLED*
Turns on/off the colorization of functions
## MAKE-COLOR-STRING
Takes either a cl-color or a list denoting the ANSI colors and
returns a string sufficient to change to the given color.
Will be dynamically controlled by *enabled* unless manually specified
otherwise
## RED
Returns a string with the `red'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## WHITE
Returns a string with the `white'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function.
## +RESET-COLOR-STRING+
This string will reset ANSI colors
# Note
Note that your terminal MUST be ANSI-compliant to show these
colors. My SLIME REPL (as of Feb 2013) does not display these
colors. I have to use a typical Linux/OSX terminal to see them.
This has been tested to work on a Linux system with SBCL, CLISP and
CCL. CCL may not work quite perfectly, some level of conniptions were
encountered in testing. The interested reader is advised to check the
MAKE-LOAD-FORM defmethod in cl-ansi-text.lisp.
An earlier variant was tested on OSX 10.6 with SBCL.
License: LLGPL

15
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/ci-test-run.sh Normal file
View file

@ -0,0 +1,15 @@
#!/bin/bash
error=0
if which sbcl; then
echo "CI run using SBCL"
sbcl --script run-tests.lisp
error=$?
fi
if which lx86cl64; then
echo "CI run using CCL"
lx86cl64 -b --load run-tests.lisp
error=$(($error+$?))
fi
exit $error

11
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text-test.asd Normal file
View file

@ -0,0 +1,11 @@
(asdf:defsystem #:cl-ansi-text-test
:depends-on ( #:cl-colors #:alexandria #:cl-ansi-text #:fiveam)
:components ((:module "test"
:components
((:file "cl-ansi-text-test"))))
:name "cl-ansi-text-test"
:version "1.0"
:maintainer "Paul Nathan"
:author "Paul Nathan"
:licence "LLGPL"
:description "Test system for cl-ansi-text")

11
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text.asd Normal file
View file

@ -0,0 +1,11 @@
(asdf:defsystem #:cl-ansi-text
:depends-on ( #:cl-colors #:alexandria)
:components ((:file "cl-ansi-text"))
:name "cl-ansi-text"
:version "1.0"
:maintainer "Paul Nathan"
:author "Paul Nathan"
:licence "LLGPL"
:description "ANSI control string characters, focused on color"
:long-description "ANSI control string management, specializing in
colors. Sometimes it is nice to have text output in colors")

285
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text.lisp Normal file
View file

@ -0,0 +1,285 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Paul Nathan 2013
;;;; cl-ansi-text.lisp
;;;;
;;;; Portions of this code were written by taksatou under the
;;;; cl-rainbow name.
;;;;
;;;; A library to produce ANSI escape sequences. Particularly,
;;;; produces colorized text on terminals
(defpackage :cl-ansi-text
(:use :common-lisp)
(:export
#:with-color
#:make-color-string
#:+reset-color-string+
#:*enabled*
#:black
#:red
#:green
#:yellow
#:blue
#:magenta
#:cyan
#:white))
(in-package :cl-ansi-text)
;;; !!! NOTE TO CCL USERS !!!
;;;
;;; This seems to be *required* to make this compile in CCL. The
;;; reason is that CCL expects to be able to inline on compile, but
;;; structs don't set up that infrastructure by default.
;;;
;;; At least from the thread "Compiler problem, MCL 3.9" by Arthur
;;; Cater around '96.
#+ccl(common-lisp:eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod make-load-form ((obj cl-colors:rgb ) &optional env)
(make-load-form-saving-slots obj)))
(defparameter *enabled* t
"Turns on/off the colorization of functions")
(defparameter +reset-color-string+
(concatenate 'string (list (code-char 27) #\[ #\0 #\m))
"This string will reset ANSI colors")
(defvar +cl-colors+
(vector
cl-colors:+black+
cl-colors:+red+
cl-colors:+green+
cl-colors:+yellow+
cl-colors:+blue+
cl-colors:+magenta+
cl-colors:+cyan+
cl-colors:+white+)
"CL-COLORS colors")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +term-colors+
(vector
:black
:red
:green
:yellow
:blue
:magenta
:cyan
:white)
"Basic colors"))
(defparameter +text-style+
'((:foreground . 30)
(:background . 40))
"One or the other. Not an ANSI effect")
(defparameter +term-effects+
'((:unset . t)
(:reset . 0)
(:bright . 1)
(:italic . 3)
(:underline . 4)
(:blink . 5)
(:inverse . 7)
(:hide . 8)
(:normal . 22)
(:framed . 51)
(:encircled . 52)
(:overlined . 53)
(:not-framed-or-circled . 54)
(:not-overlined . 55))
"ANSI terminal effects")
(defun eq-colors (a b)
"Equality for cl-colors"
;; CL-COLORS LIB!
;; eql, equal doesn't quite work for compiled cl-colors on CCL
(and
(= (cl-colors:rgb-red a)
(cl-colors:rgb-red b))
(= (cl-colors:rgb-green a)
(cl-colors:rgb-green b))
(= (cl-colors:rgb-blue a)
(cl-colors:rgb-blue b))))
(defun cl-colors-to-ansi (color)
(position color +cl-colors+ :test #'eq-colors))
(defun term-colors-to-ansi (color)
(position color +term-colors+))
;; Find-X-code is the top-level interface for code-finding
(defun find-color-code (color)
"Find the list denoting the color"
(typecase color
;; Did we get a cl-color that we know about?
(cl-colors:rgb (cl-colors-to-ansi color))
(symbol (term-colors-to-ansi color))))
(defun find-effect-code (effect)
"Returns the number for the text effect OR
t if no effect should be used OR
nil if the effect is unknown.
effect should be a member of +term-effects+"
(cdr (assoc effect +term-effects+)))
(defun find-style-code (style)
(cdr (assoc style +text-style+)))
(defun rgb-code-p (color)
(typecase color
(list t)
(integer t)))
(defun generate-control-string (code)
"General ANSI code"
(format nil "~c[~a" (code-char #o33) code))
(defun generate-color-string (code)
;; m is the action character for color
(format nil "~am" (generate-control-string code)))
(defun build-control-string (color
&optional
(effect :unset)
(style :foreground))
"Color (cl-color or term-color)
Effect
Style"
(let ((effect-code (find-effect-code effect))
(color-code (find-color-code color))
(style-code (find-style-code style)))
;; Nil here indicates an error
(assert effect-code)
(assert style-code)
;; Returns a list for inspection; next layer turns it back into a
;; string.
(concatenate
'list
;; We split between RGB and 32-color here; this preserves the
;; interface without cluttering the 32-color code up.
;;
(let ((codes nil))
(unless (eq effect-code t)
(setf codes (cons effect-code codes)))
(if (rgb-code-p color)
(setf codes (cons (rgb-color-code color style) codes))
(setf codes (cons (+ style-code color-code) codes)))
(generate-color-string (format nil "~{~A~^;~}" codes))))))
;; Public callables.
(defun make-color-string (color &key
(effect :unset)
(style :foreground)
((enabled *enabled*) *enabled*))
"Takes either a cl-color or a list denoting the ANSI colors and
returns a string sufficient to change to the given color.
Will be dynamically controlled by *enabled* unless manually specified
otherwise"
(when *enabled*
(concatenate 'string
(build-control-string color effect style))))
(defmacro with-color ((color &key
(stream t)
(effect :unset)
(style :foreground))
&body body)
"Writes out the string denoting a switch to `color`, executes body,
then writes out the string denoting a `reset`.
*enabled* dynamically controls expansion.."
`(progn
(when *enabled*
(format ,stream "~a" (make-color-string ,color
:effect ,effect
:style ,style)))
(unwind-protect
(progn
,@body)
(when *enabled*
(format ,stream "~a" +reset-color-string+)))))
(defmacro gen-color-functions (color-names-vector)
`(progn
,@(map 'list
(lambda (color)
`(defun ,(intern (symbol-name color)) (string &key
(effect :unset)
(style :foreground))
,(concatenate
'string
"Returns a string with the `" (string-downcase color)
"'string denotation preppended and the `reset' string denotation appended.
*enabled* dynamically controls the function." )
(concatenate
'string
(when *enabled*
(format nil "~a" (make-color-string ,color
:effect effect
:style style)))
string
(when *enabled*
(format nil "~a" +reset-color-string+)))))
color-names-vector)))
(gen-color-functions #.(coerce +term-colors+ 'list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RGB color codes for some enhanced terminals
;;; http://www.frexx.de/xterm-256-notes/
(defun rgb-to-ansi (red green blue)
(let ((ansi-domain (mapcar #'(lambda (x)
(floor (* 6 (/ x 256.0))))
(list red green blue))))
(+ 16
(* 36 (first ansi-domain))
(* 6 (second ansi-domain))
(third ansi-domain))))
(defun code-from-rgb (style red green blue)
(format nil "~d;5;~d"
(if (eql style :foreground) 38 48)
(rgb-to-ansi red green blue)))
(defgeneric rgb-color-code (color &optional style)
(:documentation
"Returns the 256-color code suitable for rendering on the Linux
extensions to xterm"))
(defmethod rgb-color-code ((color list) &optional (style :foreground))
(unless (consp color)
(error "~a must be a three-integer list" color))
(unless (and (integerp (first color))
(integerp (second color))
(integerp (second color)))
(error "~a must have three integers" color))
(code-from-rgb style
(first color)
(second color)
(third color)))
(defmethod rgb-color-code ((color integer) &optional (style :foreground))
;; Takes RGB integer ala Web integers
(code-from-rgb style
;; classic bitmask
(ash (logand color #xff0000) -16)
(ash (logand color #x00ff00) -8)
(logand color #x0000ff)))

29
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/run-tests.lisp Normal file
View file

@ -0,0 +1,29 @@
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
#+sbcl(require "sb-posix")
(defparameter *pwd*
(concatenate 'string
(progn #+sbcl(sb-posix:getcwd)
#+ccl(ccl::current-directory-name))
"/"))
(push *pwd* asdf:*central-registry*)
(ql:quickload '(:cl-colors
:alexandria
:fiveam
:cl-ansi-text
:cl-ansi-text-test))
(let ((result-status (cl-ansi-text-test::ci-run)))
(let ((posix-status
(if result-status 0 1)))
#+sbcl(sb-posix:exit posix-status)
#+ccl (quit posix-status)))

123
sbcl/.quicklisp/dists/quicklisp/software/cl-ansi-text-20150804-git/test/cl-ansi-text-test.lisp Normal file
View file

@ -0,0 +1,123 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; test suite for cl-ansi-text
(defpackage :cl-ansi-text-test
(:use :common-lisp
:cl-user
:cl-ansi-text
:fiveam))
(in-package :cl-ansi-text-test)
(use-package :fiveam)
(use-package :cl-ansi-text)
(def-suite test-suite
:description "test suite.")
(in-suite test-suite)
(test basic-color-strings
"Test the basic stuff"
(is (equal '(#\Esc #\[ #\3 #\1 #\m)
(cl-ansi-text::build-control-string :red :unset :foreground)))
(is (equal '(#\Esc #\[ #\4 #\1 #\m)
(cl-ansi-text::build-control-string :red :unset :background)))
(is (equal '(#\Esc #\[ #\4 #\2 #\; #\1 #\m)
(cl-ansi-text::build-control-string :green :bright :background))))
(test enabled-connectivity
"Test *enabled*'s capability"
(is (equal '(#\Esc #\[ #\3 #\1 #\m)
(let ((*enabled* t))
(concatenate
'list
(cl-ansi-text:make-color-string :red)))))
(is (equal '()
(let ((*enabled* nil))
(concatenate
'list
(cl-ansi-text:make-color-string :red)))))
(is (equal "hi"
(let ((*enabled* nil))
(with-output-to-string (s)
(with-color (:red :stream s) (format s "hi"))))))
(is (equal '(#\Esc #\[ #\3 #\1 #\m #\T #\e #\s #\t #\! #\Esc #\[ #\0 #\m)
(concatenate
'list
(with-output-to-string (s)
(with-color (:red :stream s)
(format s "Test!")))))))
(test rgb-suite
"Test RGB colors"
(is (equal '(#\Esc #\[ #\3 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m)
(cl-ansi-text::build-control-string #xFFAA00
:unset :foreground)))
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m)
(cl-ansi-text::build-control-string #xFFAA00
:unset :background)))
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\1 #\6 #\m)
(cl-ansi-text::build-control-string #x000000
:unset :background)))
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\3 #\1 #\m)
(cl-ansi-text::build-control-string #xFFFFFF
:unset :background))))
(test color-named-functions
(let ((str "Test string."))
(is (equal (black str)
(with-output-to-string (s)
(with-color (:black :stream s)
(format s str)))))
(is (equal (red str)
(with-output-to-string (s)
(with-color (:red :stream s)
(format s str)))))
(is (equal (green str)
(with-output-to-string (s)
(with-color (:green :stream s)
(format s str)))))
(is (equal (yellow str)
(with-output-to-string (s)
(with-color (:yellow :stream s)
(format s str)))))
(is (equal (blue str)
(with-output-to-string (s)
(with-color (:blue :stream s)
(format s str)))))
(is (equal (magenta str)
(with-output-to-string (s)
(with-color (:magenta :stream s)
(format s str)))))
(is (equal (cyan str)
(with-output-to-string (s)
(with-color (:cyan :stream s)
(format s str)))))
(is (equal (white str)
(with-output-to-string (s)
(with-color (:white :stream s)
(format s str)))))))
(test color-named-functions-*enabled*
(let ((str "Other test string.")
(*enabled* nil))
(is
(equal str
(white (cyan (magenta (blue (yellow (green (red (black str))))))))))))
(defun run-tests ()
(let ((results (run 'test-suite)))
(explain! results)
(if (position-if #'(lambda (e)
(eq (type-of e)
'IT.BESE.FIVEAM::TEST-FAILURE
))
results)
nil
t)))
(defun ci-run ()
(run-tests))

8
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/Makefile Normal file
View file

@ -0,0 +1,8 @@
## note: this works on my system, you don't need to run it because the
## distribution contains the generated file
SBCL=/usr/bin/sbcl
colornames.lisp: /usr/share/X11/rgb.txt parse-x11-colors.lisp
rm -f colornames.lisp
$(SBCL) --load parse-x11-colors.lisp --eval '(quit)'

43
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/README.org Normal file
View file

@ -0,0 +1,43 @@
*IMPORTANT* This library is [[https://tpapp.github.io/post/orphaned-lisp-libraries/][unsupported]].
* cl-colors: a simple color library for Common Lisp
This is a very simple color library for Common Lisp, providing
1. Types for representing colors in HSV and RGB spaces.
2. Simple conversion functions between the above types (and also hexadecimal representation for RGB).
3. Some predefined colors (currently X11 color names -- of course the library does not depend on X11).
** Examples
#+BEGIN_SRC lisp
(let ((color1 (hsv 107 62/100 52/100)) ; greenish
(color2 (rgb 14/15 26/51 14/15)) ; = violet from X11
(color3 (as-rgb "ff9e00"))) ; from hexadecimal
(list ;
(as-rgb color1) ; converting to RGB
(rgb-combination color1 +blue+ 0.4) ; HSV autoconverted to RGB
(hsv-combination color2 +blue+ 0.4) ; RGB autoconverted to HSV
color3))
#+END_SRC
evaluates to
#+BEGIN_EXAMPLE
'(#S(RGB :RED 20059/75000 :GREEN 13/25 :BLUE 247/1250)
#S(RGB :RED 0.160472 :GREEN 0.312 :BLUE 0.51856) ; observe float contagion
#S(HSV :HUE 60.0 :SATURATION 0.6722689 :VALUE 0.96000004)
#S(RGB :RED 1 :GREEN 158/255 :BLUE 0))
#+END_EXAMPLE
Observe the float contagion: =cl-colors= functions don't care about the type of the numbers as long as they are a subtype of =real= and within the right range.
** Documentation
This library is so simple that it does not need a lot of documentation --- just look at the docsstrings in =colors.lisp=.
** Regeneration of the X11 color names
Normally you should not need to do this, the sources already contain the autogenerated file =colornames.lisp=. However, if for some reason you need to regenerate this, you can use =make=. Even though the library itself does not depend on X11, regenerating this file will require the appropriate file in X11.
** Bugs and issues
Please report them on [[https://github.com/tpapp/cl-colors/issues][Github]].

19
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/cl-colors.asd Normal file
View file

@ -0,0 +1,19 @@
(defsystem #:cl-colors
:description "Simple color library for Common Lisp"
:version "0.2"
:author "Tamas K Papp <tkpapp@gmail.com>"
:license "Boost Software License - Version 1.0"
:serial t
:components ((:file "package")
(:file "colors")
(:file "colornames")
(:file "hexcolors"))
:depends-on (#:alexandria #:let-plus))
(defsystem #:cl-colors-tests
:description "Unit tests for CL-COLORS."
:author "Tamas K Papp <tkpapp@gmail.com>"
:license "Boost Software License - Version 1.0"
:serial t
:components ((:file "test"))
:depends-on (#:cl-colors #:lift))

663
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/colornames.lisp Normal file
View file

@ -0,0 +1,663 @@
;;;; This file was generated automatically by parse-x11.lisp
;;;; Please do not edit directly, just run make if necessary (but should not be).
(in-package #:cl-colors)
(define-rgb-color snow 1 50/51 50/51)
(define-rgb-color ghostwhite 248/255 248/255 1)
(define-rgb-color whitesmoke 49/51 49/51 49/51)
(define-rgb-color gainsboro 44/51 44/51 44/51)
(define-rgb-color floralwhite 1 50/51 16/17)
(define-rgb-color oldlace 253/255 49/51 46/51)
(define-rgb-color linen 50/51 16/17 46/51)
(define-rgb-color antiquewhite 50/51 47/51 43/51)
(define-rgb-color papayawhip 1 239/255 71/85)
(define-rgb-color blanchedalmond 1 47/51 41/51)
(define-rgb-color bisque 1 76/85 196/255)
(define-rgb-color peachpuff 1 218/255 37/51)
(define-rgb-color navajowhite 1 74/85 173/255)
(define-rgb-color moccasin 1 76/85 181/255)
(define-rgb-color cornsilk 1 248/255 44/51)
(define-rgb-color ivory 1 1 16/17)
(define-rgb-color lemonchiffon 1 50/51 41/51)
(define-rgb-color seashell 1 49/51 14/15)
(define-rgb-color honeydew 16/17 1 16/17)
(define-rgb-color mintcream 49/51 1 50/51)
(define-rgb-color azure 16/17 1 1)
(define-rgb-color aliceblue 16/17 248/255 1)
(define-rgb-color lavender 46/51 46/51 50/51)
(define-rgb-color lavenderblush 1 16/17 49/51)
(define-rgb-color mistyrose 1 76/85 15/17)
(define-rgb-color white 1 1 1)
(define-rgb-color black 0 0 0)
(define-rgb-color darkslategray 47/255 79/255 79/255)
(define-rgb-color darkslategrey 47/255 79/255 79/255)
(define-rgb-color dimgray 7/17 7/17 7/17)
(define-rgb-color dimgrey 7/17 7/17 7/17)
(define-rgb-color slategray 112/255 128/255 48/85)
(define-rgb-color slategrey 112/255 128/255 48/85)
(define-rgb-color lightslategray 7/15 8/15 3/5)
(define-rgb-color lightslategrey 7/15 8/15 3/5)
(define-rgb-color gray 38/51 38/51 38/51)
(define-rgb-color grey 38/51 38/51 38/51)
(define-rgb-color lightgrey 211/255 211/255 211/255)
(define-rgb-color lightgray 211/255 211/255 211/255)
(define-rgb-color midnightblue 5/51 5/51 112/255)
(define-rgb-color navy 0 0 128/255)
(define-rgb-color navyblue 0 0 128/255)
(define-rgb-color cornflowerblue 20/51 149/255 79/85)
(define-rgb-color darkslateblue 24/85 61/255 139/255)
(define-rgb-color slateblue 106/255 6/17 41/51)
(define-rgb-color mediumslateblue 41/85 104/255 14/15)
(define-rgb-color lightslateblue 44/85 112/255 1)
(define-rgb-color mediumblue 0 0 41/51)
(define-rgb-color royalblue 13/51 7/17 15/17)
(define-rgb-color blue 0 0 1)
(define-rgb-color dodgerblue 2/17 48/85 1)
(define-rgb-color deepskyblue 0 191/255 1)
(define-rgb-color skyblue 9/17 206/255 47/51)
(define-rgb-color lightskyblue 9/17 206/255 50/51)
(define-rgb-color steelblue 14/51 26/51 12/17)
(define-rgb-color lightsteelblue 176/255 196/255 74/85)
(define-rgb-color lightblue 173/255 72/85 46/51)
(define-rgb-color powderblue 176/255 224/255 46/51)
(define-rgb-color paleturquoise 35/51 14/15 14/15)
(define-rgb-color darkturquoise 0 206/255 209/255)
(define-rgb-color mediumturquoise 24/85 209/255 4/5)
(define-rgb-color turquoise 64/255 224/255 208/255)
(define-rgb-color cyan 0 1 1)
(define-rgb-color lightcyan 224/255 1 1)
(define-rgb-color cadetblue 19/51 158/255 32/51)
(define-rgb-color mediumaquamarine 2/5 41/51 2/3)
(define-rgb-color aquamarine 127/255 1 212/255)
(define-rgb-color darkgreen 0 20/51 0)
(define-rgb-color darkolivegreen 1/3 107/255 47/255)
(define-rgb-color darkseagreen 143/255 188/255 143/255)
(define-rgb-color seagreen 46/255 139/255 29/85)
(define-rgb-color mediumseagreen 4/17 179/255 113/255)
(define-rgb-color lightseagreen 32/255 178/255 2/3)
(define-rgb-color palegreen 152/255 251/255 152/255)
(define-rgb-color springgreen 0 1 127/255)
(define-rgb-color lawngreen 124/255 84/85 0)
(define-rgb-color green 0 1 0)
(define-rgb-color chartreuse 127/255 1 0)
(define-rgb-color mediumspringgreen 0 50/51 154/255)
(define-rgb-color greenyellow 173/255 1 47/255)
(define-rgb-color limegreen 10/51 41/51 10/51)
(define-rgb-color yellowgreen 154/255 41/51 10/51)
(define-rgb-color forestgreen 2/15 139/255 2/15)
(define-rgb-color olivedrab 107/255 142/255 7/51)
(define-rgb-color darkkhaki 63/85 61/85 107/255)
(define-rgb-color khaki 16/17 46/51 28/51)
(define-rgb-color palegoldenrod 14/15 232/255 2/3)
(define-rgb-color lightgoldenrodyellow 50/51 50/51 14/17)
(define-rgb-color lightyellow 1 1 224/255)
(define-rgb-color yellow 1 1 0)
(define-rgb-color gold 1 43/51 0)
(define-rgb-color lightgoldenrod 14/15 13/15 26/51)
(define-rgb-color goldenrod 218/255 11/17 32/255)
(define-rgb-color darkgoldenrod 184/255 134/255 11/255)
(define-rgb-color rosybrown 188/255 143/255 143/255)
(define-rgb-color indianred 41/51 92/255 92/255)
(define-rgb-color saddlebrown 139/255 23/85 19/255)
(define-rgb-color sienna 32/51 82/255 3/17)
(define-rgb-color peru 41/51 133/255 21/85)
(define-rgb-color burlywood 74/85 184/255 9/17)
(define-rgb-color beige 49/51 49/51 44/51)
(define-rgb-color wheat 49/51 74/85 179/255)
(define-rgb-color sandybrown 244/255 164/255 32/85)
(define-rgb-color tan 14/17 12/17 28/51)
(define-rgb-color chocolate 14/17 7/17 2/17)
(define-rgb-color firebrick 178/255 2/15 2/15)
(define-rgb-color brown 11/17 14/85 14/85)
(define-rgb-color darksalmon 233/255 10/17 122/255)
(define-rgb-color salmon 50/51 128/255 38/85)
(define-rgb-color lightsalmon 1 32/51 122/255)
(define-rgb-color orange 1 11/17 0)
(define-rgb-color darkorange 1 28/51 0)
(define-rgb-color coral 1 127/255 16/51)
(define-rgb-color lightcoral 16/17 128/255 128/255)
(define-rgb-color tomato 1 33/85 71/255)
(define-rgb-color orangered 1 23/85 0)
(define-rgb-color red 1 0 0)
(define-rgb-color hotpink 1 7/17 12/17)
(define-rgb-color deeppink 1 4/51 49/85)
(define-rgb-color pink 1 64/85 203/255)
(define-rgb-color lightpink 1 182/255 193/255)
(define-rgb-color palevioletred 73/85 112/255 49/85)
(define-rgb-color maroon 176/255 16/85 32/85)
(define-rgb-color mediumvioletred 199/255 7/85 133/255)
(define-rgb-color violetred 208/255 32/255 48/85)
(define-rgb-color magenta 1 0 1)
(define-rgb-color violet 14/15 26/51 14/15)
(define-rgb-color plum 13/15 32/51 13/15)
(define-rgb-color orchid 218/255 112/255 214/255)
(define-rgb-color mediumorchid 62/85 1/3 211/255)
(define-rgb-color darkorchid 3/5 10/51 4/5)
(define-rgb-color darkviolet 148/255 0 211/255)
(define-rgb-color blueviolet 46/85 43/255 226/255)
(define-rgb-color purple 32/51 32/255 16/17)
(define-rgb-color mediumpurple 49/85 112/255 73/85)
(define-rgb-color thistle 72/85 191/255 72/85)
(define-rgb-color snow1 1 50/51 50/51)
(define-rgb-color snow2 14/15 233/255 233/255)
(define-rgb-color snow3 41/51 67/85 67/85)
(define-rgb-color snow4 139/255 137/255 137/255)
(define-rgb-color seashell1 1 49/51 14/15)
(define-rgb-color seashell2 14/15 229/255 74/85)
(define-rgb-color seashell3 41/51 197/255 191/255)
(define-rgb-color seashell4 139/255 134/255 26/51)
(define-rgb-color antiquewhite1 1 239/255 73/85)
(define-rgb-color antiquewhite2 14/15 223/255 4/5)
(define-rgb-color antiquewhite3 41/51 64/85 176/255)
(define-rgb-color antiquewhite4 139/255 131/255 8/17)
(define-rgb-color bisque1 1 76/85 196/255)
(define-rgb-color bisque2 14/15 71/85 61/85)
(define-rgb-color bisque3 41/51 61/85 158/255)
(define-rgb-color bisque4 139/255 25/51 107/255)
(define-rgb-color peachpuff1 1 218/255 37/51)
(define-rgb-color peachpuff2 14/15 203/255 173/255)
(define-rgb-color peachpuff3 41/51 35/51 149/255)
(define-rgb-color peachpuff4 139/255 7/15 101/255)
(define-rgb-color navajowhite1 1 74/85 173/255)
(define-rgb-color navajowhite2 14/15 69/85 161/255)
(define-rgb-color navajowhite3 41/51 179/255 139/255)
(define-rgb-color navajowhite4 139/255 121/255 94/255)
(define-rgb-color lemonchiffon1 1 50/51 41/51)
(define-rgb-color lemonchiffon2 14/15 233/255 191/255)
(define-rgb-color lemonchiffon3 41/51 67/85 11/17)
(define-rgb-color lemonchiffon4 139/255 137/255 112/255)
(define-rgb-color cornsilk1 1 248/255 44/51)
(define-rgb-color cornsilk2 14/15 232/255 41/51)
(define-rgb-color cornsilk3 41/51 40/51 59/85)
(define-rgb-color cornsilk4 139/255 8/15 8/17)
(define-rgb-color ivory1 1 1 16/17)
(define-rgb-color ivory2 14/15 14/15 224/255)
(define-rgb-color ivory3 41/51 41/51 193/255)
(define-rgb-color ivory4 139/255 139/255 131/255)
(define-rgb-color honeydew1 16/17 1 16/17)
(define-rgb-color honeydew2 224/255 14/15 224/255)
(define-rgb-color honeydew3 193/255 41/51 193/255)
(define-rgb-color honeydew4 131/255 139/255 131/255)
(define-rgb-color lavenderblush1 1 16/17 49/51)
(define-rgb-color lavenderblush2 14/15 224/255 229/255)
(define-rgb-color lavenderblush3 41/51 193/255 197/255)
(define-rgb-color lavenderblush4 139/255 131/255 134/255)
(define-rgb-color mistyrose1 1 76/85 15/17)
(define-rgb-color mistyrose2 14/15 71/85 14/17)
(define-rgb-color mistyrose3 41/51 61/85 181/255)
(define-rgb-color mistyrose4 139/255 25/51 41/85)
(define-rgb-color azure1 16/17 1 1)
(define-rgb-color azure2 224/255 14/15 14/15)
(define-rgb-color azure3 193/255 41/51 41/51)
(define-rgb-color azure4 131/255 139/255 139/255)
(define-rgb-color slateblue1 131/255 37/85 1)
(define-rgb-color slateblue2 122/255 103/255 14/15)
(define-rgb-color slateblue3 7/17 89/255 41/51)
(define-rgb-color slateblue4 71/255 4/17 139/255)
(define-rgb-color royalblue1 24/85 118/255 1)
(define-rgb-color royalblue2 67/255 22/51 14/15)
(define-rgb-color royalblue3 58/255 19/51 41/51)
(define-rgb-color royalblue4 13/85 64/255 139/255)
(define-rgb-color blue1 0 0 1)
(define-rgb-color blue2 0 0 14/15)
(define-rgb-color blue3 0 0 41/51)
(define-rgb-color blue4 0 0 139/255)
(define-rgb-color dodgerblue1 2/17 48/85 1)
(define-rgb-color dodgerblue2 28/255 134/255 14/15)
(define-rgb-color dodgerblue3 8/85 116/255 41/51)
(define-rgb-color dodgerblue4 16/255 26/85 139/255)
(define-rgb-color steelblue1 33/85 184/255 1)
(define-rgb-color steelblue2 92/255 172/255 14/15)
(define-rgb-color steelblue3 79/255 148/255 41/51)
(define-rgb-color steelblue4 18/85 20/51 139/255)
(define-rgb-color deepskyblue1 0 191/255 1)
(define-rgb-color deepskyblue2 0 178/255 14/15)
(define-rgb-color deepskyblue3 0 154/255 41/51)
(define-rgb-color deepskyblue4 0 104/255 139/255)
(define-rgb-color skyblue1 9/17 206/255 1)
(define-rgb-color skyblue2 42/85 64/85 14/15)
(define-rgb-color skyblue3 36/85 166/255 41/51)
(define-rgb-color skyblue4 74/255 112/255 139/255)
(define-rgb-color lightskyblue1 176/255 226/255 1)
(define-rgb-color lightskyblue2 164/255 211/255 14/15)
(define-rgb-color lightskyblue3 47/85 182/255 41/51)
(define-rgb-color lightskyblue4 32/85 41/85 139/255)
(define-rgb-color slategray1 66/85 226/255 1)
(define-rgb-color slategray2 37/51 211/255 14/15)
(define-rgb-color slategray3 53/85 182/255 41/51)
(define-rgb-color slategray4 36/85 41/85 139/255)
(define-rgb-color lightsteelblue1 202/255 15/17 1)
(define-rgb-color lightsteelblue2 188/255 14/17 14/15)
(define-rgb-color lightsteelblue3 54/85 181/255 41/51)
(define-rgb-color lightsteelblue4 22/51 41/85 139/255)
(define-rgb-color lightblue1 191/255 239/255 1)
(define-rgb-color lightblue2 178/255 223/255 14/15)
(define-rgb-color lightblue3 154/255 64/85 41/51)
(define-rgb-color lightblue4 104/255 131/255 139/255)
(define-rgb-color lightcyan1 224/255 1 1)
(define-rgb-color lightcyan2 209/255 14/15 14/15)
(define-rgb-color lightcyan3 12/17 41/51 41/51)
(define-rgb-color lightcyan4 122/255 139/255 139/255)
(define-rgb-color paleturquoise1 11/15 1 1)
(define-rgb-color paleturquoise2 58/85 14/15 14/15)
(define-rgb-color paleturquoise3 10/17 41/51 41/51)
(define-rgb-color paleturquoise4 2/5 139/255 139/255)
(define-rgb-color cadetblue1 152/255 49/51 1)
(define-rgb-color cadetblue2 142/255 229/255 14/15)
(define-rgb-color cadetblue3 122/255 197/255 41/51)
(define-rgb-color cadetblue4 83/255 134/255 139/255)
(define-rgb-color turquoise1 0 49/51 1)
(define-rgb-color turquoise2 0 229/255 14/15)
(define-rgb-color turquoise3 0 197/255 41/51)
(define-rgb-color turquoise4 0 134/255 139/255)
(define-rgb-color cyan1 0 1 1)
(define-rgb-color cyan2 0 14/15 14/15)
(define-rgb-color cyan3 0 41/51 41/51)
(define-rgb-color cyan4 0 139/255 139/255)
(define-rgb-color darkslategray1 151/255 1 1)
(define-rgb-color darkslategray2 47/85 14/15 14/15)
(define-rgb-color darkslategray3 121/255 41/51 41/51)
(define-rgb-color darkslategray4 82/255 139/255 139/255)
(define-rgb-color aquamarine1 127/255 1 212/255)
(define-rgb-color aquamarine2 118/255 14/15 66/85)
(define-rgb-color aquamarine3 2/5 41/51 2/3)
(define-rgb-color aquamarine4 23/85 139/255 116/255)
(define-rgb-color darkseagreen1 193/255 1 193/255)
(define-rgb-color darkseagreen2 12/17 14/15 12/17)
(define-rgb-color darkseagreen3 31/51 41/51 31/51)
(define-rgb-color darkseagreen4 7/17 139/255 7/17)
(define-rgb-color seagreen1 28/85 1 53/85)
(define-rgb-color seagreen2 26/85 14/15 148/255)
(define-rgb-color seagreen3 67/255 41/51 128/255)
(define-rgb-color seagreen4 46/255 139/255 29/85)
(define-rgb-color palegreen1 154/255 1 154/255)
(define-rgb-color palegreen2 48/85 14/15 48/85)
(define-rgb-color palegreen3 124/255 41/51 124/255)
(define-rgb-color palegreen4 28/85 139/255 28/85)
(define-rgb-color springgreen1 0 1 127/255)
(define-rgb-color springgreen2 0 14/15 118/255)
(define-rgb-color springgreen3 0 41/51 2/5)
(define-rgb-color springgreen4 0 139/255 23/85)
(define-rgb-color green1 0 1 0)
(define-rgb-color green2 0 14/15 0)
(define-rgb-color green3 0 41/51 0)
(define-rgb-color green4 0 139/255 0)
(define-rgb-color chartreuse1 127/255 1 0)
(define-rgb-color chartreuse2 118/255 14/15 0)
(define-rgb-color chartreuse3 2/5 41/51 0)
(define-rgb-color chartreuse4 23/85 139/255 0)
(define-rgb-color olivedrab1 64/85 1 62/255)
(define-rgb-color olivedrab2 179/255 14/15 58/255)
(define-rgb-color olivedrab3 154/255 41/51 10/51)
(define-rgb-color olivedrab4 7/17 139/255 2/15)
(define-rgb-color darkolivegreen1 202/255 1 112/255)
(define-rgb-color darkolivegreen2 188/255 14/15 104/255)
(define-rgb-color darkolivegreen3 54/85 41/51 6/17)
(define-rgb-color darkolivegreen4 22/51 139/255 61/255)
(define-rgb-color khaki1 1 82/85 143/255)
(define-rgb-color khaki2 14/15 46/51 133/255)
(define-rgb-color khaki3 41/51 66/85 23/51)
(define-rgb-color khaki4 139/255 134/255 26/85)
(define-rgb-color lightgoldenrod1 1 236/255 139/255)
(define-rgb-color lightgoldenrod2 14/15 44/51 26/51)
(define-rgb-color lightgoldenrod3 41/51 38/51 112/255)
(define-rgb-color lightgoldenrod4 139/255 43/85 76/255)
(define-rgb-color lightyellow1 1 1 224/255)
(define-rgb-color lightyellow2 14/15 14/15 209/255)
(define-rgb-color lightyellow3 41/51 41/51 12/17)
(define-rgb-color lightyellow4 139/255 139/255 122/255)
(define-rgb-color yellow1 1 1 0)
(define-rgb-color yellow2 14/15 14/15 0)
(define-rgb-color yellow3 41/51 41/51 0)
(define-rgb-color yellow4 139/255 139/255 0)
(define-rgb-color gold1 1 43/51 0)
(define-rgb-color gold2 14/15 67/85 0)
(define-rgb-color gold3 41/51 173/255 0)
(define-rgb-color gold4 139/255 39/85 0)
(define-rgb-color goldenrod1 1 193/255 37/255)
(define-rgb-color goldenrod2 14/15 12/17 2/15)
(define-rgb-color goldenrod3 41/51 31/51 29/255)
(define-rgb-color goldenrod4 139/255 7/17 4/51)
(define-rgb-color darkgoldenrod1 1 37/51 1/17)
(define-rgb-color darkgoldenrod2 14/15 173/255 14/255)
(define-rgb-color darkgoldenrod3 41/51 149/255 4/85)
(define-rgb-color darkgoldenrod4 139/255 101/255 8/255)
(define-rgb-color rosybrown1 1 193/255 193/255)
(define-rgb-color rosybrown2 14/15 12/17 12/17)
(define-rgb-color rosybrown3 41/51 31/51 31/51)
(define-rgb-color rosybrown4 139/255 7/17 7/17)
(define-rgb-color indianred1 1 106/255 106/255)
(define-rgb-color indianred2 14/15 33/85 33/85)
(define-rgb-color indianred3 41/51 1/3 1/3)
(define-rgb-color indianred4 139/255 58/255 58/255)
(define-rgb-color sienna1 1 26/51 71/255)
(define-rgb-color sienna2 14/15 121/255 22/85)
(define-rgb-color sienna3 41/51 104/255 19/85)
(define-rgb-color sienna4 139/255 71/255 38/255)
(define-rgb-color burlywood1 1 211/255 31/51)
(define-rgb-color burlywood2 14/15 197/255 29/51)
(define-rgb-color burlywood3 41/51 2/3 25/51)
(define-rgb-color burlywood4 139/255 23/51 1/3)
(define-rgb-color wheat1 1 77/85 62/85)
(define-rgb-color wheat2 14/15 72/85 58/85)
(define-rgb-color wheat3 41/51 62/85 10/17)
(define-rgb-color wheat4 139/255 42/85 2/5)
(define-rgb-color tan1 1 11/17 79/255)
(define-rgb-color tan2 14/15 154/255 73/255)
(define-rgb-color tan3 41/51 133/255 21/85)
(define-rgb-color tan4 139/255 6/17 43/255)
(define-rgb-color chocolate1 1 127/255 12/85)
(define-rgb-color chocolate2 14/15 118/255 11/85)
(define-rgb-color chocolate3 41/51 2/5 29/255)
(define-rgb-color chocolate4 139/255 23/85 19/255)
(define-rgb-color firebrick1 1 16/85 16/85)
(define-rgb-color firebrick2 14/15 44/255 44/255)
(define-rgb-color firebrick3 41/51 38/255 38/255)
(define-rgb-color firebrick4 139/255 26/255 26/255)
(define-rgb-color brown1 1 64/255 64/255)
(define-rgb-color brown2 14/15 59/255 59/255)
(define-rgb-color brown3 41/51 1/5 1/5)
(define-rgb-color brown4 139/255 7/51 7/51)
(define-rgb-color salmon1 1 28/51 7/17)
(define-rgb-color salmon2 14/15 26/51 98/255)
(define-rgb-color salmon3 41/51 112/255 28/85)
(define-rgb-color salmon4 139/255 76/255 19/85)
(define-rgb-color lightsalmon1 1 32/51 122/255)
(define-rgb-color lightsalmon2 14/15 149/255 38/85)
(define-rgb-color lightsalmon3 41/51 43/85 98/255)
(define-rgb-color lightsalmon4 139/255 29/85 22/85)
(define-rgb-color orange1 1 11/17 0)
(define-rgb-color orange2 14/15 154/255 0)
(define-rgb-color orange3 41/51 133/255 0)
(define-rgb-color orange4 139/255 6/17 0)
(define-rgb-color darkorange1 1 127/255 0)
(define-rgb-color darkorange2 14/15 118/255 0)
(define-rgb-color darkorange3 41/51 2/5 0)
(define-rgb-color darkorange4 139/255 23/85 0)
(define-rgb-color coral1 1 38/85 86/255)
(define-rgb-color coral2 14/15 106/255 16/51)
(define-rgb-color coral3 41/51 91/255 23/85)
(define-rgb-color coral4 139/255 62/255 47/255)
(define-rgb-color tomato1 1 33/85 71/255)
(define-rgb-color tomato2 14/15 92/255 22/85)
(define-rgb-color tomato3 41/51 79/255 19/85)
(define-rgb-color tomato4 139/255 18/85 38/255)
(define-rgb-color orangered1 1 23/85 0)
(define-rgb-color orangered2 14/15 64/255 0)
(define-rgb-color orangered3 41/51 11/51 0)
(define-rgb-color orangered4 139/255 37/255 0)
(define-rgb-color red1 1 0 0)
(define-rgb-color red2 14/15 0 0)
(define-rgb-color red3 41/51 0 0)
(define-rgb-color red4 139/255 0 0)
(define-rgb-color debianred 43/51 7/255 27/85)
(define-rgb-color deeppink1 1 4/51 49/85)
(define-rgb-color deeppink2 14/15 6/85 137/255)
(define-rgb-color deeppink3 41/51 16/255 118/255)
(define-rgb-color deeppink4 139/255 2/51 16/51)
(define-rgb-color hotpink1 1 22/51 12/17)
(define-rgb-color hotpink2 14/15 106/255 167/255)
(define-rgb-color hotpink3 41/51 32/85 48/85)
(define-rgb-color hotpink4 139/255 58/255 98/255)
(define-rgb-color pink1 1 181/255 197/255)
(define-rgb-color pink2 14/15 169/255 184/255)
(define-rgb-color pink3 41/51 29/51 158/255)
(define-rgb-color pink4 139/255 33/85 36/85)
(define-rgb-color lightpink1 1 58/85 37/51)
(define-rgb-color lightpink2 14/15 54/85 173/255)
(define-rgb-color lightpink3 41/51 28/51 149/255)
(define-rgb-color lightpink4 139/255 19/51 101/255)
(define-rgb-color palevioletred1 1 26/51 57/85)
(define-rgb-color palevioletred2 14/15 121/255 53/85)
(define-rgb-color palevioletred3 41/51 104/255 137/255)
(define-rgb-color palevioletred4 139/255 71/255 31/85)
(define-rgb-color maroon1 1 52/255 179/255)
(define-rgb-color maroon2 14/15 16/85 167/255)
(define-rgb-color maroon3 41/51 41/255 48/85)
(define-rgb-color maroon4 139/255 28/255 98/255)
(define-rgb-color violetred1 1 62/255 10/17)
(define-rgb-color violetred2 14/15 58/255 28/51)
(define-rgb-color violetred3 41/51 10/51 8/17)
(define-rgb-color violetred4 139/255 2/15 82/255)
(define-rgb-color magenta1 1 0 1)
(define-rgb-color magenta2 14/15 0 14/15)
(define-rgb-color magenta3 41/51 0 41/51)
(define-rgb-color magenta4 139/255 0 139/255)
(define-rgb-color orchid1 1 131/255 50/51)
(define-rgb-color orchid2 14/15 122/255 233/255)
(define-rgb-color orchid3 41/51 7/17 67/85)
(define-rgb-color orchid4 139/255 71/255 137/255)
(define-rgb-color plum1 1 11/15 1)
(define-rgb-color plum2 14/15 58/85 14/15)
(define-rgb-color plum3 41/51 10/17 41/51)
(define-rgb-color plum4 139/255 2/5 139/255)
(define-rgb-color mediumorchid1 224/255 2/5 1)
(define-rgb-color mediumorchid2 209/255 19/51 14/15)
(define-rgb-color mediumorchid3 12/17 82/255 41/51)
(define-rgb-color mediumorchid4 122/255 11/51 139/255)
(define-rgb-color darkorchid1 191/255 62/255 1)
(define-rgb-color darkorchid2 178/255 58/255 14/15)
(define-rgb-color darkorchid3 154/255 10/51 41/51)
(define-rgb-color darkorchid4 104/255 2/15 139/255)
(define-rgb-color purple1 31/51 16/85 1)
(define-rgb-color purple2 29/51 44/255 14/15)
(define-rgb-color purple3 25/51 38/255 41/51)
(define-rgb-color purple4 1/3 26/255 139/255)
(define-rgb-color mediumpurple1 57/85 26/51 1)
(define-rgb-color mediumpurple2 53/85 121/255 14/15)
(define-rgb-color mediumpurple3 137/255 104/255 41/51)
(define-rgb-color mediumpurple4 31/85 71/255 139/255)
(define-rgb-color thistle1 1 15/17 1)
(define-rgb-color thistle2 14/15 14/17 14/15)
(define-rgb-color thistle3 41/51 181/255 41/51)
(define-rgb-color thistle4 139/255 41/85 139/255)
(define-rgb-color gray0 0 0 0)
(define-rgb-color grey0 0 0 0)
(define-rgb-color gray1 1/85 1/85 1/85)
(define-rgb-color grey1 1/85 1/85 1/85)
(define-rgb-color gray2 1/51 1/51 1/51)
(define-rgb-color grey2 1/51 1/51 1/51)
(define-rgb-color gray3 8/255 8/255 8/255)
(define-rgb-color grey3 8/255 8/255 8/255)
(define-rgb-color gray4 2/51 2/51 2/51)
(define-rgb-color grey4 2/51 2/51 2/51)
(define-rgb-color gray5 13/255 13/255 13/255)
(define-rgb-color grey5 13/255 13/255 13/255)
(define-rgb-color gray6 1/17 1/17 1/17)
(define-rgb-color grey6 1/17 1/17 1/17)
(define-rgb-color gray7 6/85 6/85 6/85)
(define-rgb-color grey7 6/85 6/85 6/85)
(define-rgb-color gray8 4/51 4/51 4/51)
(define-rgb-color grey8 4/51 4/51 4/51)
(define-rgb-color gray9 23/255 23/255 23/255)
(define-rgb-color grey9 23/255 23/255 23/255)
(define-rgb-color gray10 26/255 26/255 26/255)
(define-rgb-color grey10 26/255 26/255 26/255)
(define-rgb-color gray11 28/255 28/255 28/255)
(define-rgb-color grey11 28/255 28/255 28/255)
(define-rgb-color gray12 31/255 31/255 31/255)
(define-rgb-color grey12 31/255 31/255 31/255)
(define-rgb-color gray13 11/85 11/85 11/85)
(define-rgb-color grey13 11/85 11/85 11/85)
(define-rgb-color gray14 12/85 12/85 12/85)
(define-rgb-color grey14 12/85 12/85 12/85)
(define-rgb-color gray15 38/255 38/255 38/255)
(define-rgb-color grey15 38/255 38/255 38/255)
(define-rgb-color gray16 41/255 41/255 41/255)
(define-rgb-color grey16 41/255 41/255 41/255)
(define-rgb-color gray17 43/255 43/255 43/255)
(define-rgb-color grey17 43/255 43/255 43/255)
(define-rgb-color gray18 46/255 46/255 46/255)
(define-rgb-color grey18 46/255 46/255 46/255)
(define-rgb-color gray19 16/85 16/85 16/85)
(define-rgb-color grey19 16/85 16/85 16/85)
(define-rgb-color gray20 1/5 1/5 1/5)
(define-rgb-color grey20 1/5 1/5 1/5)
(define-rgb-color gray21 18/85 18/85 18/85)
(define-rgb-color grey21 18/85 18/85 18/85)
(define-rgb-color gray22 56/255 56/255 56/255)
(define-rgb-color grey22 56/255 56/255 56/255)
(define-rgb-color gray23 59/255 59/255 59/255)
(define-rgb-color grey23 59/255 59/255 59/255)
(define-rgb-color gray24 61/255 61/255 61/255)
(define-rgb-color grey24 61/255 61/255 61/255)
(define-rgb-color gray25 64/255 64/255 64/255)
(define-rgb-color grey25 64/255 64/255 64/255)
(define-rgb-color gray26 22/85 22/85 22/85)
(define-rgb-color grey26 22/85 22/85 22/85)
(define-rgb-color gray27 23/85 23/85 23/85)
(define-rgb-color grey27 23/85 23/85 23/85)
(define-rgb-color gray28 71/255 71/255 71/255)
(define-rgb-color grey28 71/255 71/255 71/255)
(define-rgb-color gray29 74/255 74/255 74/255)
(define-rgb-color grey29 74/255 74/255 74/255)
(define-rgb-color gray30 77/255 77/255 77/255)
(define-rgb-color grey30 77/255 77/255 77/255)
(define-rgb-color gray31 79/255 79/255 79/255)
(define-rgb-color grey31 79/255 79/255 79/255)
(define-rgb-color gray32 82/255 82/255 82/255)
(define-rgb-color grey32 82/255 82/255 82/255)
(define-rgb-color gray33 28/85 28/85 28/85)
(define-rgb-color grey33 28/85 28/85 28/85)
(define-rgb-color gray34 29/85 29/85 29/85)
(define-rgb-color grey34 29/85 29/85 29/85)
(define-rgb-color gray35 89/255 89/255 89/255)
(define-rgb-color grey35 89/255 89/255 89/255)
(define-rgb-color gray36 92/255 92/255 92/255)
(define-rgb-color grey36 92/255 92/255 92/255)
(define-rgb-color gray37 94/255 94/255 94/255)
(define-rgb-color grey37 94/255 94/255 94/255)
(define-rgb-color gray38 97/255 97/255 97/255)
(define-rgb-color grey38 97/255 97/255 97/255)
(define-rgb-color gray39 33/85 33/85 33/85)
(define-rgb-color grey39 33/85 33/85 33/85)
(define-rgb-color gray40 2/5 2/5 2/5)
(define-rgb-color grey40 2/5 2/5 2/5)
(define-rgb-color gray41 7/17 7/17 7/17)
(define-rgb-color grey41 7/17 7/17 7/17)
(define-rgb-color gray42 107/255 107/255 107/255)
(define-rgb-color grey42 107/255 107/255 107/255)
(define-rgb-color gray43 22/51 22/51 22/51)
(define-rgb-color grey43 22/51 22/51 22/51)
(define-rgb-color gray44 112/255 112/255 112/255)
(define-rgb-color grey44 112/255 112/255 112/255)
(define-rgb-color gray45 23/51 23/51 23/51)
(define-rgb-color grey45 23/51 23/51 23/51)
(define-rgb-color gray46 39/85 39/85 39/85)
(define-rgb-color grey46 39/85 39/85 39/85)
(define-rgb-color gray47 8/17 8/17 8/17)
(define-rgb-color grey47 8/17 8/17 8/17)
(define-rgb-color gray48 122/255 122/255 122/255)
(define-rgb-color grey48 122/255 122/255 122/255)
(define-rgb-color gray49 25/51 25/51 25/51)
(define-rgb-color grey49 25/51 25/51 25/51)
(define-rgb-color gray50 127/255 127/255 127/255)
(define-rgb-color grey50 127/255 127/255 127/255)
(define-rgb-color gray51 26/51 26/51 26/51)
(define-rgb-color grey51 26/51 26/51 26/51)
(define-rgb-color gray52 133/255 133/255 133/255)
(define-rgb-color grey52 133/255 133/255 133/255)
(define-rgb-color gray53 9/17 9/17 9/17)
(define-rgb-color grey53 9/17 9/17 9/17)
(define-rgb-color gray54 46/85 46/85 46/85)
(define-rgb-color grey54 46/85 46/85 46/85)
(define-rgb-color gray55 28/51 28/51 28/51)
(define-rgb-color grey55 28/51 28/51 28/51)
(define-rgb-color gray56 143/255 143/255 143/255)
(define-rgb-color grey56 143/255 143/255 143/255)
(define-rgb-color gray57 29/51 29/51 29/51)
(define-rgb-color grey57 29/51 29/51 29/51)
(define-rgb-color gray58 148/255 148/255 148/255)
(define-rgb-color grey58 148/255 148/255 148/255)
(define-rgb-color gray59 10/17 10/17 10/17)
(define-rgb-color grey59 10/17 10/17 10/17)
(define-rgb-color gray60 3/5 3/5 3/5)
(define-rgb-color grey60 3/5 3/5 3/5)
(define-rgb-color gray61 52/85 52/85 52/85)
(define-rgb-color grey61 52/85 52/85 52/85)
(define-rgb-color gray62 158/255 158/255 158/255)
(define-rgb-color grey62 158/255 158/255 158/255)
(define-rgb-color gray63 161/255 161/255 161/255)
(define-rgb-color grey63 161/255 161/255 161/255)
(define-rgb-color gray64 163/255 163/255 163/255)
(define-rgb-color grey64 163/255 163/255 163/255)
(define-rgb-color gray65 166/255 166/255 166/255)
(define-rgb-color grey65 166/255 166/255 166/255)
(define-rgb-color gray66 56/85 56/85 56/85)
(define-rgb-color grey66 56/85 56/85 56/85)
(define-rgb-color gray67 57/85 57/85 57/85)
(define-rgb-color grey67 57/85 57/85 57/85)
(define-rgb-color gray68 173/255 173/255 173/255)
(define-rgb-color grey68 173/255 173/255 173/255)
(define-rgb-color gray69 176/255 176/255 176/255)
(define-rgb-color grey69 176/255 176/255 176/255)
(define-rgb-color gray70 179/255 179/255 179/255)
(define-rgb-color grey70 179/255 179/255 179/255)
(define-rgb-color gray71 181/255 181/255 181/255)
(define-rgb-color grey71 181/255 181/255 181/255)
(define-rgb-color gray72 184/255 184/255 184/255)
(define-rgb-color grey72 184/255 184/255 184/255)
(define-rgb-color gray73 62/85 62/85 62/85)
(define-rgb-color grey73 62/85 62/85 62/85)
(define-rgb-color gray74 63/85 63/85 63/85)
(define-rgb-color grey74 63/85 63/85 63/85)
(define-rgb-color gray75 191/255 191/255 191/255)
(define-rgb-color grey75 191/255 191/255 191/255)
(define-rgb-color gray76 194/255 194/255 194/255)
(define-rgb-color grey76 194/255 194/255 194/255)
(define-rgb-color gray77 196/255 196/255 196/255)
(define-rgb-color grey77 196/255 196/255 196/255)
(define-rgb-color gray78 199/255 199/255 199/255)
(define-rgb-color grey78 199/255 199/255 199/255)
(define-rgb-color gray79 67/85 67/85 67/85)
(define-rgb-color grey79 67/85 67/85 67/85)
(define-rgb-color gray80 4/5 4/5 4/5)
(define-rgb-color grey80 4/5 4/5 4/5)
(define-rgb-color gray81 69/85 69/85 69/85)
(define-rgb-color grey81 69/85 69/85 69/85)
(define-rgb-color gray82 209/255 209/255 209/255)
(define-rgb-color grey82 209/255 209/255 209/255)
(define-rgb-color gray83 212/255 212/255 212/255)
(define-rgb-color grey83 212/255 212/255 212/255)
(define-rgb-color gray84 214/255 214/255 214/255)
(define-rgb-color grey84 214/255 214/255 214/255)
(define-rgb-color gray85 217/255 217/255 217/255)
(define-rgb-color grey85 217/255 217/255 217/255)
(define-rgb-color gray86 73/85 73/85 73/85)
(define-rgb-color grey86 73/85 73/85 73/85)
(define-rgb-color gray87 74/85 74/85 74/85)
(define-rgb-color grey87 74/85 74/85 74/85)
(define-rgb-color gray88 224/255 224/255 224/255)
(define-rgb-color grey88 224/255 224/255 224/255)
(define-rgb-color gray89 227/255 227/255 227/255)
(define-rgb-color grey89 227/255 227/255 227/255)
(define-rgb-color gray90 229/255 229/255 229/255)
(define-rgb-color grey90 229/255 229/255 229/255)
(define-rgb-color gray91 232/255 232/255 232/255)
(define-rgb-color grey91 232/255 232/255 232/255)
(define-rgb-color gray92 47/51 47/51 47/51)
(define-rgb-color grey92 47/51 47/51 47/51)
(define-rgb-color gray93 79/85 79/85 79/85)
(define-rgb-color grey93 79/85 79/85 79/85)
(define-rgb-color gray94 16/17 16/17 16/17)
(define-rgb-color grey94 16/17 16/17 16/17)
(define-rgb-color gray95 242/255 242/255 242/255)
(define-rgb-color grey95 242/255 242/255 242/255)
(define-rgb-color gray96 49/51 49/51 49/51)
(define-rgb-color grey96 49/51 49/51 49/51)
(define-rgb-color gray97 247/255 247/255 247/255)
(define-rgb-color grey97 247/255 247/255 247/255)
(define-rgb-color gray98 50/51 50/51 50/51)
(define-rgb-color grey98 50/51 50/51 50/51)
(define-rgb-color gray99 84/85 84/85 84/85)
(define-rgb-color grey99 84/85 84/85 84/85)
(define-rgb-color gray100 1 1 1)
(define-rgb-color grey100 1 1 1)
(define-rgb-color darkgrey 169/255 169/255 169/255)
(define-rgb-color darkgray 169/255 169/255 169/255)
(define-rgb-color darkblue 0 0 139/255)
(define-rgb-color darkcyan 0 139/255 139/255)
(define-rgb-color darkmagenta 139/255 0 139/255)
(define-rgb-color darkred 139/255 0 0)
(define-rgb-color lightgreen 48/85 14/15 48/85)

167
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/colors.lisp Normal file
View file

@ -0,0 +1,167 @@
(in-package :cl-colors)
;;; color representations
(deftype unit-real ()
"Real number in [0,1]."
'(real 0 1))
(defstruct (rgb (:constructor rgb (red green blue)))
"RGB color."
(red nil :type unit-real :read-only t)
(green nil :type unit-real :read-only t)
(blue nil :type unit-real :read-only t))
(defmethod make-load-form ((p rgb) &optional env)
(declare (ignore env))
(make-load-form-saving-slots p))
(defun gray (value)
"Create an RGB representation of a gray color (value in [0,1)."
(rgb value value value))
(define-structure-let+ (rgb) red green blue)
(defstruct (hsv (:constructor hsv (hue saturation value)))
"HSV color."
(hue nil :type (real 0 360) :read-only t)
(saturation nil :type unit-real :read-only t)
(value nil :type unit-real :read-only t))
(defmethod make-load-form ((p hsv) &optional env)
(declare (ignore env))
(make-load-form-saving-slots p))
(define-structure-let+ (hsv) hue saturation value)
(defun normalize-hue (hue)
"Normalize hue to the interval [0,360)."
(mod hue 360))
;;; conversions
(defun rgb-to-hsv (rgb &optional (undefined-hue 0))
"Convert RGB to HSV representation. When hue is undefined (saturation is
zero), UNDEFINED-HUE will be assigned."
(let+ (((&rgb red green blue) rgb)
(value (max red green blue))
(delta (- value (min red green blue)))
(saturation (if (plusp value)
(/ delta value)
0))
((&flet normalize (constant right left)
(let ((hue (+ constant (/ (* 60 (- right left)) delta))))
(if (minusp hue)
(+ hue 360)
hue)))))
(hsv (cond
((zerop saturation) undefined-hue) ; undefined
((= red value) (normalize 0 green blue)) ; dominant red
((= green value) (normalize 120 blue red)) ; dominant green
(t (normalize 240 red green)))
saturation
value)))
(defun hsv-to-rgb (hsv)
"Convert HSV to RGB representation. When SATURATION is zero, HUE is
ignored."
(let+ (((&hsv hue saturation value) hsv))
;; if saturation=0, color is on the gray line
(when (zerop saturation)
(return-from hsv-to-rgb (gray value)))
;; nonzero saturation: normalize hue to [0,6)
(let+ ((h (/ (normalize-hue hue) 60))
((&values quotient remainder) (floor h))
(p (* value (- 1 saturation)))
(q (* value (- 1 (* saturation remainder))))
(r (* value (- 1 (* saturation (- 1 remainder)))))
((&values red green blue) (case quotient
(0 (values value r p))
(1 (values q value p))
(2 (values p value r))
(3 (values p q value))
(4 (values r p value))
(t (values value p q)))))
(rgb red green blue))))
(defun hex-to-rgb (string)
"Parse hexadecimal notation (eg ff0000 or f00 for red) into an RGB color."
(let+ (((&values width max)
(case (length string)
(3 (values 1 15))
(6 (values 2 255))
(t (error "string ~A doesn't have length 3 or 6, can't parse as ~
RGB specification" string))))
((&flet parse (index)
(/ (parse-integer string :start (* index width)
:end (* (1+ index) width)
:radix 16)
max))))
(rgb (parse 0) (parse 1) (parse 2))))
;;; conversion with generic functions
(defgeneric as-hsv (color &optional undefined-hue)
(:method ((color rgb) &optional (undefined-hue 0))
(rgb-to-hsv color undefined-hue))
(:method ((color hsv) &optional undefined-hue)
(declare (ignore undefined-hue))
color))
(defgeneric as-rgb (color)
(:method ((rgb rgb))
rgb)
(:method ((hsv hsv))
(hsv-to-rgb hsv))
(:method ((string string))
;; TODO in the long run this should recognize color names too
(hex-to-rgb string)))
;;; combinations
;;; internal functions
(declaim (inline cc))
(defun cc (a b alpha)
"Convex combination (1-ALPHA)*A+ALPHA*B, ie ALPHA is the weight of A."
(declare (type (real 0 1) alpha))
(+ (* (- 1 alpha) a) (* alpha b)))
(defun rgb-combination (color1 color2 alpha)
"Color combination in RGB space."
(let+ (((&rgb red1 green1 blue1) (as-rgb color1))
((&rgb red2 green2 blue2) (as-rgb color2))
((&flet c (c1 c2) (cc c1 c2 alpha))))
(rgb (c red1 red2)
(c green1 green2)
(c blue1 blue2))))
(defun hsv-combination (hsv1 hsv2 alpha &optional (positive? t))
"Color combination in HSV space. POSITIVE? determines whether the hue
combination is in the positive or negative direction on the color wheel."
(let+ (((&hsv hue1 saturation1 value1) (as-hsv hsv1))
((&hsv hue2 saturation2 value2) (as-hsv hsv2))
((&flet c (c1 c2) (cc c1 c2 alpha))))
(hsv (cond
((and positive? (> hue1 hue2))
(normalize-hue (c hue1 (+ hue2 360))))
((and (not positive?) (< hue1 hue2))
(normalize-hue (c (+ hue1 360) hue2)))
(t (c hue1 hue2)))
(c saturation1 saturation2)
(c value1 value2))))
;;; macros used by the autogenerated files
(defmacro define-rgb-color (name red green blue)
"Macro for defining color constants. Used by the automatically generated color file."
(let ((constant-name (symbolicate #\+ name #\+)))
`(progn
(define-constant ,constant-name (rgb ,red ,green ,blue)
:test #'equalp :documentation ,(format nil "X11 color ~A." name)))))

69
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/hexcolors.lisp Normal file
View file

@ -0,0 +1,69 @@
(in-package #:cl-colors)
;;; parsing and printing of CSS-like colors
(defun print-hex-rgb (color &key short (hash T) alpha destination)
"Converts a COLOR to its hexadecimal RGB string representation. If
SHORT is specified each component gets just one character.
A hash character (#) is prepended if HASH is true (default).
If ALPHA is set it is included as an ALPHA component.
DESTINATION is the first argument to FORMAT, by default NIL."
(let+ (((&rgb red green blue) (as-rgb color))
(factor (if short 15 255))
((&flet c (x) (round (* x factor)))))
(format destination (if short
"~@[~C~]~X~X~X~@[~X~]"
"~@[~C~]~2,'0X~2,'0X~2,'0X~@[~X~]")
(and hash #\#)
(c red) (c green) (c blue)
(and alpha (c alpha)))))
;; TODO: a JUNK-ALLOWED parameter, like for PARSE-INTEGER, would be nice
(defun parse-hex-rgb (string &key (start 0) end)
"Parses a hexadecimal RGB(A) color string. Returns a new RGB color value
and an alpha component if present."
(let* ((length (length string))
(end (or end length))
(sub-length (- end start)))
(cond
;; check for valid range, we need at least three and accept at most
;; nine characters
((and (<= #.(length "fff") sub-length)
(<= sub-length #.(length "#ffffff00")))
(when (char= (char string start) #\#)
(incf start)
(decf sub-length))
(labels ((parse (string index offset)
(parse-integer string :start index :end (+ offset index)
:radix 16))
(short (string index)
(/ (parse string index 1) 15))
(long (string index)
(/ (parse string index 2) 255)))
;; recognize possible combinations of alpha component and length
;; of the rest of the encoded color
(multiple-value-bind (shortp alphap)
(case sub-length
(#.(length "fff") (values T NIL))
(#.(length "fff0") (values T T))
(#.(length "ffffff") (values NIL NIL))
(#.(length "ffffff00") (values NIL T)))
(if shortp
(values
(rgb
(short string start)
(short string (+ 1 start))
(short string (+ 2 start)))
(and alphap (short string (+ 3 start))))
(values
(rgb
(long string start)
(long string (+ 2 start))
(long string (+ 4 start)))
(and alphap (long string (+ 6 start))))))))
(T
(error "not enough or too many characters in indicated sequence: ~A"
(subseq string start end))))))

52
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/introduction.txt Normal file
View file

@ -0,0 +1,52 @@
Color classes
-------------
The two main color classes are rgb and hsv, which have slots red,
green, blue and hue, saturation, value respectively. There is also an
rgb class with an alpha channel (slot alpha) called rgba. In the rgb
class, valid slot values are from 0 to 1, while in the hsv class,
saturation and value are in the interval [0,1], but hue is in [0,360).
You can convert between rgb and hsv using rgb->hsv and hsv->rgb. Note
that for the former, you need to specify what happens when the hue is
undefined (ie the color is gray). By default, the hue of red (0) is
assigned.
Generic functions which find the appropriate conversion method are
available with names ->rgb and ->hsv. Use these if you want your
functions to handle various different color representations but
eventually you need to work with a single one.
Named colors
------------
Named colors, parsed from the X11 colors file, are loaded from
colornames.lisp. As they are constants, names are between +'s. All
named colors are rgb.
Convex combinations
-------------------
Use hsv-combination or rgb-combination for taking convex combinations
in the respective color space. Note that in the HSV space, you need
to specify the direction on the color wheel, the default is positive.
Example session
---------------
CL-COLORS> +blue+
#<RGB red: 0.0d0 green: 0.0d0 blue: 1.0d0>
CL-COLORS> (->hsv +blue+)
#<HSV hue: 240.0d0 saturation: 1.0d0 value: 1.0d0>
CL-COLORS> (rgb-combination +blue+ +green+ 0.5)
#<RGB red: 0.0d0 green: 0.5d0 blue: 0.5d0>
CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5))
#<RGB red: 1.0d0 green: 0.0d0 blue: 0.0d0>
CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5 nil))
#<RGB red: 0.0d0 green: 1.0d0 blue: 1.0d0>

17
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/package-template.lisp Normal file
View file

@ -0,0 +1,17 @@
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
(in-package #:common-lisp-user)
(defpackage #:cl-colors
(:use #:alexandria
#:common-lisp
#:let-plus)
(:export
#:rgb #:rgb-red #:rgb-green #:rgb-blue #:gray #:&rgb
#:hsv #:hsv-hue #:hsv-saturation #:hsv-value #:&hsv
#:rgb-to-hsv #:hsv-to-rgb #:hex-to-rgb #:as-hsv #:as-rgb
#:rgb-combination #:hsv-combination
#:parse-hex-rgb #:print-hex-rgb
;; predefined color names
~A))

674
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/package.lisp Normal file
View file

@ -0,0 +1,674 @@
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
(in-package #:common-lisp-user)
(defpackage #:cl-colors
(:use #:alexandria
#:common-lisp
#:let-plus)
(:export
#:rgb #:rgb-red #:rgb-green #:rgb-blue #:gray #:&rgb
#:hsv #:hsv-hue #:hsv-saturation #:hsv-value #:&hsv
#:rgb-to-hsv #:hsv-to-rgb #:hex-to-rgb #:as-hsv #:as-rgb
#:rgb-combination #:hsv-combination
#:parse-hex-rgb #:print-hex-rgb
;; predefined color names
#:+snow+
#:+ghostwhite+
#:+whitesmoke+
#:+gainsboro+
#:+floralwhite+
#:+oldlace+
#:+linen+
#:+antiquewhite+
#:+papayawhip+
#:+blanchedalmond+
#:+bisque+
#:+peachpuff+
#:+navajowhite+
#:+moccasin+
#:+cornsilk+
#:+ivory+
#:+lemonchiffon+
#:+seashell+
#:+honeydew+
#:+mintcream+
#:+azure+
#:+aliceblue+
#:+lavender+
#:+lavenderblush+
#:+mistyrose+
#:+white+
#:+black+
#:+darkslategray+
#:+darkslategrey+
#:+dimgray+
#:+dimgrey+
#:+slategray+
#:+slategrey+
#:+lightslategray+
#:+lightslategrey+
#:+gray+
#:+grey+
#:+lightgrey+
#:+lightgray+
#:+midnightblue+
#:+navy+
#:+navyblue+
#:+cornflowerblue+
#:+darkslateblue+
#:+slateblue+
#:+mediumslateblue+
#:+lightslateblue+
#:+mediumblue+
#:+royalblue+
#:+blue+
#:+dodgerblue+
#:+deepskyblue+
#:+skyblue+
#:+lightskyblue+
#:+steelblue+
#:+lightsteelblue+
#:+lightblue+
#:+powderblue+
#:+paleturquoise+
#:+darkturquoise+
#:+mediumturquoise+
#:+turquoise+
#:+cyan+
#:+lightcyan+
#:+cadetblue+
#:+mediumaquamarine+
#:+aquamarine+
#:+darkgreen+
#:+darkolivegreen+
#:+darkseagreen+
#:+seagreen+
#:+mediumseagreen+
#:+lightseagreen+
#:+palegreen+
#:+springgreen+
#:+lawngreen+
#:+green+
#:+chartreuse+
#:+mediumspringgreen+
#:+greenyellow+
#:+limegreen+
#:+yellowgreen+
#:+forestgreen+
#:+olivedrab+
#:+darkkhaki+
#:+khaki+
#:+palegoldenrod+
#:+lightgoldenrodyellow+
#:+lightyellow+
#:+yellow+
#:+gold+
#:+lightgoldenrod+
#:+goldenrod+
#:+darkgoldenrod+
#:+rosybrown+
#:+indianred+
#:+saddlebrown+
#:+sienna+
#:+peru+
#:+burlywood+
#:+beige+
#:+wheat+
#:+sandybrown+
#:+tan+
#:+chocolate+
#:+firebrick+
#:+brown+
#:+darksalmon+
#:+salmon+
#:+lightsalmon+
#:+orange+
#:+darkorange+
#:+coral+
#:+lightcoral+
#:+tomato+
#:+orangered+
#:+red+
#:+hotpink+
#:+deeppink+
#:+pink+
#:+lightpink+
#:+palevioletred+
#:+maroon+
#:+mediumvioletred+
#:+violetred+
#:+magenta+
#:+violet+
#:+plum+
#:+orchid+
#:+mediumorchid+
#:+darkorchid+
#:+darkviolet+
#:+blueviolet+
#:+purple+
#:+mediumpurple+
#:+thistle+
#:+snow1+
#:+snow2+
#:+snow3+
#:+snow4+
#:+seashell1+
#:+seashell2+
#:+seashell3+
#:+seashell4+
#:+antiquewhite1+
#:+antiquewhite2+
#:+antiquewhite3+
#:+antiquewhite4+
#:+bisque1+
#:+bisque2+
#:+bisque3+
#:+bisque4+
#:+peachpuff1+
#:+peachpuff2+
#:+peachpuff3+
#:+peachpuff4+
#:+navajowhite1+
#:+navajowhite2+
#:+navajowhite3+
#:+navajowhite4+
#:+lemonchiffon1+
#:+lemonchiffon2+
#:+lemonchiffon3+
#:+lemonchiffon4+
#:+cornsilk1+
#:+cornsilk2+
#:+cornsilk3+
#:+cornsilk4+
#:+ivory1+
#:+ivory2+
#:+ivory3+
#:+ivory4+
#:+honeydew1+
#:+honeydew2+
#:+honeydew3+
#:+honeydew4+
#:+lavenderblush1+
#:+lavenderblush2+
#:+lavenderblush3+
#:+lavenderblush4+
#:+mistyrose1+
#:+mistyrose2+
#:+mistyrose3+
#:+mistyrose4+
#:+azure1+
#:+azure2+
#:+azure3+
#:+azure4+
#:+slateblue1+
#:+slateblue2+
#:+slateblue3+
#:+slateblue4+
#:+royalblue1+
#:+royalblue2+
#:+royalblue3+
#:+royalblue4+
#:+blue1+
#:+blue2+
#:+blue3+
#:+blue4+
#:+dodgerblue1+
#:+dodgerblue2+
#:+dodgerblue3+
#:+dodgerblue4+
#:+steelblue1+
#:+steelblue2+
#:+steelblue3+
#:+steelblue4+
#:+deepskyblue1+
#:+deepskyblue2+
#:+deepskyblue3+
#:+deepskyblue4+
#:+skyblue1+
#:+skyblue2+
#:+skyblue3+
#:+skyblue4+
#:+lightskyblue1+
#:+lightskyblue2+
#:+lightskyblue3+
#:+lightskyblue4+
#:+slategray1+
#:+slategray2+
#:+slategray3+
#:+slategray4+
#:+lightsteelblue1+
#:+lightsteelblue2+
#:+lightsteelblue3+
#:+lightsteelblue4+
#:+lightblue1+
#:+lightblue2+
#:+lightblue3+
#:+lightblue4+
#:+lightcyan1+
#:+lightcyan2+
#:+lightcyan3+
#:+lightcyan4+
#:+paleturquoise1+
#:+paleturquoise2+
#:+paleturquoise3+
#:+paleturquoise4+
#:+cadetblue1+
#:+cadetblue2+
#:+cadetblue3+
#:+cadetblue4+
#:+turquoise1+
#:+turquoise2+
#:+turquoise3+
#:+turquoise4+
#:+cyan1+
#:+cyan2+
#:+cyan3+
#:+cyan4+
#:+darkslategray1+
#:+darkslategray2+
#:+darkslategray3+
#:+darkslategray4+
#:+aquamarine1+
#:+aquamarine2+
#:+aquamarine3+
#:+aquamarine4+
#:+darkseagreen1+
#:+darkseagreen2+
#:+darkseagreen3+
#:+darkseagreen4+
#:+seagreen1+
#:+seagreen2+
#:+seagreen3+
#:+seagreen4+
#:+palegreen1+
#:+palegreen2+
#:+palegreen3+
#:+palegreen4+
#:+springgreen1+
#:+springgreen2+
#:+springgreen3+
#:+springgreen4+
#:+green1+
#:+green2+
#:+green3+
#:+green4+
#:+chartreuse1+
#:+chartreuse2+
#:+chartreuse3+
#:+chartreuse4+
#:+olivedrab1+
#:+olivedrab2+
#:+olivedrab3+
#:+olivedrab4+
#:+darkolivegreen1+
#:+darkolivegreen2+
#:+darkolivegreen3+
#:+darkolivegreen4+
#:+khaki1+
#:+khaki2+
#:+khaki3+
#:+khaki4+
#:+lightgoldenrod1+
#:+lightgoldenrod2+
#:+lightgoldenrod3+
#:+lightgoldenrod4+
#:+lightyellow1+
#:+lightyellow2+
#:+lightyellow3+
#:+lightyellow4+
#:+yellow1+
#:+yellow2+
#:+yellow3+
#:+yellow4+
#:+gold1+
#:+gold2+
#:+gold3+
#:+gold4+
#:+goldenrod1+
#:+goldenrod2+
#:+goldenrod3+
#:+goldenrod4+
#:+darkgoldenrod1+
#:+darkgoldenrod2+
#:+darkgoldenrod3+
#:+darkgoldenrod4+
#:+rosybrown1+
#:+rosybrown2+
#:+rosybrown3+
#:+rosybrown4+
#:+indianred1+
#:+indianred2+
#:+indianred3+
#:+indianred4+
#:+sienna1+
#:+sienna2+
#:+sienna3+
#:+sienna4+
#:+burlywood1+
#:+burlywood2+
#:+burlywood3+
#:+burlywood4+
#:+wheat1+
#:+wheat2+
#:+wheat3+
#:+wheat4+
#:+tan1+
#:+tan2+
#:+tan3+
#:+tan4+
#:+chocolate1+
#:+chocolate2+
#:+chocolate3+
#:+chocolate4+
#:+firebrick1+
#:+firebrick2+
#:+firebrick3+
#:+firebrick4+
#:+brown1+
#:+brown2+
#:+brown3+
#:+brown4+
#:+salmon1+
#:+salmon2+
#:+salmon3+
#:+salmon4+
#:+lightsalmon1+
#:+lightsalmon2+
#:+lightsalmon3+
#:+lightsalmon4+
#:+orange1+
#:+orange2+
#:+orange3+
#:+orange4+
#:+darkorange1+
#:+darkorange2+
#:+darkorange3+
#:+darkorange4+
#:+coral1+
#:+coral2+
#:+coral3+
#:+coral4+
#:+tomato1+
#:+tomato2+
#:+tomato3+
#:+tomato4+
#:+orangered1+
#:+orangered2+
#:+orangered3+
#:+orangered4+
#:+red1+
#:+red2+
#:+red3+
#:+red4+
#:+debianred+
#:+deeppink1+
#:+deeppink2+
#:+deeppink3+
#:+deeppink4+
#:+hotpink1+
#:+hotpink2+
#:+hotpink3+
#:+hotpink4+
#:+pink1+
#:+pink2+
#:+pink3+
#:+pink4+
#:+lightpink1+
#:+lightpink2+
#:+lightpink3+
#:+lightpink4+
#:+palevioletred1+
#:+palevioletred2+
#:+palevioletred3+
#:+palevioletred4+
#:+maroon1+
#:+maroon2+
#:+maroon3+
#:+maroon4+
#:+violetred1+
#:+violetred2+
#:+violetred3+
#:+violetred4+
#:+magenta1+
#:+magenta2+
#:+magenta3+
#:+magenta4+
#:+orchid1+
#:+orchid2+
#:+orchid3+
#:+orchid4+
#:+plum1+
#:+plum2+
#:+plum3+
#:+plum4+
#:+mediumorchid1+
#:+mediumorchid2+
#:+mediumorchid3+
#:+mediumorchid4+
#:+darkorchid1+
#:+darkorchid2+
#:+darkorchid3+
#:+darkorchid4+
#:+purple1+
#:+purple2+
#:+purple3+
#:+purple4+
#:+mediumpurple1+
#:+mediumpurple2+
#:+mediumpurple3+
#:+mediumpurple4+
#:+thistle1+
#:+thistle2+
#:+thistle3+
#:+thistle4+
#:+gray0+
#:+grey0+
#:+gray1+
#:+grey1+
#:+gray2+
#:+grey2+
#:+gray3+
#:+grey3+
#:+gray4+
#:+grey4+
#:+gray5+
#:+grey5+
#:+gray6+
#:+grey6+
#:+gray7+
#:+grey7+
#:+gray8+
#:+grey8+
#:+gray9+
#:+grey9+
#:+gray10+
#:+grey10+
#:+gray11+
#:+grey11+
#:+gray12+
#:+grey12+
#:+gray13+
#:+grey13+
#:+gray14+
#:+grey14+
#:+gray15+
#:+grey15+
#:+gray16+
#:+grey16+
#:+gray17+
#:+grey17+
#:+gray18+
#:+grey18+
#:+gray19+
#:+grey19+
#:+gray20+
#:+grey20+
#:+gray21+
#:+grey21+
#:+gray22+
#:+grey22+
#:+gray23+
#:+grey23+
#:+gray24+
#:+grey24+
#:+gray25+
#:+grey25+
#:+gray26+
#:+grey26+
#:+gray27+
#:+grey27+
#:+gray28+
#:+grey28+
#:+gray29+
#:+grey29+
#:+gray30+
#:+grey30+
#:+gray31+
#:+grey31+
#:+gray32+
#:+grey32+
#:+gray33+
#:+grey33+
#:+gray34+
#:+grey34+
#:+gray35+
#:+grey35+
#:+gray36+
#:+grey36+
#:+gray37+
#:+grey37+
#:+gray38+
#:+grey38+
#:+gray39+
#:+grey39+
#:+gray40+
#:+grey40+
#:+gray41+
#:+grey41+
#:+gray42+
#:+grey42+
#:+gray43+
#:+grey43+
#:+gray44+
#:+grey44+
#:+gray45+
#:+grey45+
#:+gray46+
#:+grey46+
#:+gray47+
#:+grey47+
#:+gray48+
#:+grey48+
#:+gray49+
#:+grey49+
#:+gray50+
#:+grey50+
#:+gray51+
#:+grey51+
#:+gray52+
#:+grey52+
#:+gray53+
#:+grey53+
#:+gray54+
#:+grey54+
#:+gray55+
#:+grey55+
#:+gray56+
#:+grey56+
#:+gray57+
#:+grey57+
#:+gray58+
#:+grey58+
#:+gray59+
#:+grey59+
#:+gray60+
#:+grey60+
#:+gray61+
#:+grey61+
#:+gray62+
#:+grey62+
#:+gray63+
#:+grey63+
#:+gray64+
#:+grey64+
#:+gray65+
#:+grey65+
#:+gray66+
#:+grey66+
#:+gray67+
#:+grey67+
#:+gray68+
#:+grey68+
#:+gray69+
#:+grey69+
#:+gray70+
#:+grey70+
#:+gray71+
#:+grey71+
#:+gray72+
#:+grey72+
#:+gray73+
#:+grey73+
#:+gray74+
#:+grey74+
#:+gray75+
#:+grey75+
#:+gray76+
#:+grey76+
#:+gray77+
#:+grey77+
#:+gray78+
#:+grey78+
#:+gray79+
#:+grey79+
#:+gray80+
#:+grey80+
#:+gray81+
#:+grey81+
#:+gray82+
#:+grey82+
#:+gray83+
#:+grey83+
#:+gray84+
#:+grey84+
#:+gray85+
#:+grey85+
#:+gray86+
#:+grey86+
#:+gray87+
#:+grey87+
#:+gray88+
#:+grey88+
#:+gray89+
#:+grey89+
#:+gray90+
#:+grey90+
#:+gray91+
#:+grey91+
#:+gray92+
#:+grey92+
#:+gray93+
#:+grey93+
#:+gray94+
#:+grey94+
#:+gray95+
#:+grey95+
#:+gray96+
#:+grey96+
#:+gray97+
#:+grey97+
#:+gray98+
#:+grey98+
#:+gray99+
#:+grey99+
#:+gray100+
#:+grey100+
#:+darkgrey+
#:+darkgray+
#:+darkblue+
#:+darkcyan+
#:+darkmagenta+
#:+darkred+
#:+lightgreen+))

68
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/parse-x11-colors.lisp Normal file
View file

@ -0,0 +1,68 @@
;;; parse X11's rgb.txt
;;;
;;; no packages defined as this should just be run as a script.
(require :cl-ppcre)
(require :alexandria)
(defun write-package-file (colornames
&key (package-template-path "package-template.lisp")
(package-file-path "package.lisp"))
"Write a package definition file, exporting COLORNAMES, using the given template."
(let* ((package-template (alexandria:read-file-into-string package-template-path))
(colornames-export
(reduce (lambda (a b) (format nil "~A~%~A" a b))
colornames
:key (lambda (colorname)
(format nil " #:+~A+" colorname)))))
(with-open-file (package-file package-file-path
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format package-file package-template colornames-export))
(values)))
(defun parse-and-write-color-definitions (&key
(source-path "/usr/share/X11/rgb.txt")
(destination-path "colornames.lisp"))
"Parse color definitions and write them into a file. Return the list of colors (for exporting)."
(let ((color-scanner ; will only take names w/o spaces
(cl-ppcre:create-scanner
"^\\s*(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+([\\s\\w]+\?)\\s*$"
:extended-mode t))
(comment-scanner (cl-ppcre:create-scanner "^\\s*!"))
colornames)
(with-open-file (source source-path
:direction :input
:if-does-not-exist :error)
(with-open-file (colordefs destination-path
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format colordefs ";;;; This file was generated automatically ~
by parse-x11.lisp~%~
;;;; Please do not edit directly, just run make if necessary (but should not be).~2%~
(in-package #:cl-colors)~2%")
(labels ((parse-channel (string)
(let ((i (read-from-string string)))
(assert (and (typep i 'integer) (<= i 255)))
(/ i 255))))
(do ((line (read-line source nil nil) (read-line source nil nil)))
((not line))
(unless (cl-ppcre:scan-to-strings comment-scanner line)
(multiple-value-bind (match registers)
(cl-ppcre:scan-to-strings color-scanner line)
(if (and match (not (find #\space (aref registers 3))))
(let ((colorname (string-downcase (aref registers 3))))
(format colordefs
"(define-rgb-color ~A ~A ~A ~A)~%"
colorname
(parse-channel (aref registers 0))
(parse-channel (aref registers 1))
(parse-channel (aref registers 2)))
(push colorname colornames))
(format t "ignoring line ~A~%" line)))))))
(nreverse colornames))))
(let ((colornames (parse-and-write-color-definitions)))
(write-package-file colornames))

82
sbcl/.quicklisp/dists/quicklisp/software/cl-colors-20180328-git/test.lisp Normal file
View file

@ -0,0 +1,82 @@
(in-package #:cl-user)
(defpackage #:cl-colors-tests
(:use #:alexandria #:common-lisp #:cl-colors #:let-plus #:lift)
(:export #:run))
(in-package #:cl-colors-tests)
(deftestsuite cl-colors-tests () ())
(defun run ()
"Run all the tests for CL-COLORS-TESTS."
(run-tests :suite 'cl-colors-tests))
(defun eps= (a b &optional (epsilon 1e-10))
(<= (abs (- a b)) epsilon))
(defun rgb= (rgb1 rgb2 &optional (epsilon 1e-10))
"Compare RGB colors for (numerical) equality."
(let+ (((&rgb red1 green1 blue1) rgb1)
((&rgb red2 green2 blue2) rgb2))
(and (eps= red1 red2 epsilon)
(eps= green1 green2 epsilon)
(eps= blue1 blue2 epsilon))))
(defun random-rgb ()
(rgb (random 1d0) (random 1d0) (random 1d0)))
(addtest (cl-colors-tests)
rgb<->hsv
(loop repeat 100 do
(let ((rgb (random-rgb)))
(ensure-same rgb (as-rgb (as-hsv rgb)) :test #'rgb=))))
;; (defun test-hue-combination (from to positivep)
;; (dotimes (i 21)
;; (format t "~a " (hue-combination from to (/ i 20) positivep))))
(addtest (cl-colors-tests)
print-hex-rgb
(let ((rgb (rgb 0.070 0.203 0.337)))
(ensure-same "#123456" (print-hex-rgb rgb))
(ensure-same "123456" (print-hex-rgb rgb :hash nil))
(ensure-same "#135" (print-hex-rgb rgb :short t))
(ensure-same "135" (print-hex-rgb rgb :hash nil :short t))
(ensure-same "#12345678" (print-hex-rgb rgb :alpha 0.47))
(ensure-same "12345678" (print-hex-rgb rgb :alpha 0.47 :hash nil))
(ensure-same "#1357" (print-hex-rgb rgb :alpha 0.47 :short t))
(ensure-same "1357" (print-hex-rgb rgb :alpha 0.47 :hash nil :short t))))
(addtest (cl-colors-tests)
parse-hex-rgb
(let ((rgb (rgb 0.070 0.203 0.337)))
(ensure-same rgb (parse-hex-rgb "#123456") :test (rcurry #'rgb= 0.01))
(ensure-same rgb (parse-hex-rgb "123456") :test (rcurry #'rgb= 0.01))
(ensure-same rgb (parse-hex-rgb "#135") :test (rcurry #'rgb= 0.01))
(ensure-same rgb (parse-hex-rgb "135") :test (rcurry #'rgb= 0.01))
(flet ((aux (list1 list2)
(and (rgb= (car list1) (car list2) 0.01)
(eps= (cadr list1) (cadr list2) 0.01))))
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#12345678")) :test #'aux)
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "12345678")) :test #'aux)
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#1357")) :test #'aux)
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "1357")) :test #'aux))))
(addtest (cl-colors-tests)
print-hex-rgb/format
(ensure-same "#123456" (with-output-to-string (*standard-output*)
(print-hex-rgb (rgb 0.070 0.203 0.337)
:destination T))))
(addtest (cl-colors-tests)
hex<->rgb
(loop repeat 100 do
(let ((rgb (random-rgb)))
(ensure-same rgb (parse-hex-rgb (print-hex-rgb rgb)) :test (rcurry #'rgb= 0.01)))))
(addtest (cl-colors-tests)
parse-hex-rgb-ranges
(ensure-same (rgb 0.070 0.203 0.337) (parse-hex-rgb "foo#123456zzz" :start 3 :end 10)
:test (rcurry #'rgb= 0.001)))

14
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/LICENSE.txt Normal file
View file

@ -0,0 +1,14 @@
CL-EMB has fixes by current maintainer, Michael Raskin <38a938c2@rambler.ru>
This fixes are Copyright (c) 2009 by Moscow Center of Continious
Mathematical Education.
CL-EMB is written and Copyright (c) 2004, 2005, 2006 by Stefan Scholl.
Parts of the source are taken from LSP, written by
John Wiseman and copyright 2001, 2002 I/NET Inc.
See lsp-LICENSE.txt
CL-EMB is licensed under the terms of the Lisp Lesser GNU
Public License (http://opensource.franz.com/preamble.html), known as
the LLGPL. The LLGPL consists of a preamble (see above URL) and the
LGPL. Where these conflict, the preamble takes precedence.
CL-EMB is referenced in the preamble as the "LIBRARY."

339
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/README.md Normal file
View file

@ -0,0 +1,339 @@
# cl-emb: Embedded Common Lisp
A mixture of features from eRuby and HTML::Template. You could name it "Yet
Another LSP" (LispServer Pages) but it's a bit more than that and not limited to
a certain server or text format.
This is a mirror of http://mtn-host.prjek.net/projects/cl-emb
The primary development repository is in Monotone, this repository will receive
just the automated snapshots.
# License
[LLGPL](http://opensource.franz.com/preamble.html)
# Installing
```lisp
(ql:quickload :cl-emb)
```
CL-EMB can also be installed manually with [ASDF-INSTALL](http://weitz.de/asdf-install/).
# Usage
## [generic function] `EXECUTE-EMB name &key env generator-maker => string`
`NAME` can be a registered (with `REGISTER-EMB`) emb code or a pathname (type
`PATHNAME`) of a file containing the code. Returns a string. Keyword parameter
ENV to pass objects to the code. `ENV` must be a plist. `ENV` can be accessed
within your emb code. The `GENERATOR-MAKER` is a function which gets called
with a key and value from the given `ENV` and should return a generator function
like described
[here](http://www.cs.northwestern.edu/academics/courses/325/readings/graham/generators.html).
## [generic function] `REGISTER-EMB name code => emb-function`
Internally registeres given `CODE` with `NAME` to be called with
`EXECUTE-EMB`. `CODE` can be a string or a pathname (type `PATHNAME`) of a file
containing the code.
## [function] `PPRINT-EMB-FUNCTION name`
`DEBUG` function. Pretty prints function form, if `*DEBUG*` was `T` when the
function was registered.
## [function] `CLEAR-EMB name`
Remove named emb code.
## [function] `CLEAR-EMB-ALL`
Remove all registered emb code.
## [function] `CLEAR-EMB-ALL-FILES`
Remove all registered file emb code (registered/executed by a pathname).
## [special variable] `*EMB-START-MARKER*` (default `"<%"`)
Start of scriptlet or expression. Remember that a following `#\=` indicates an
expression.
## [special variable] `*EMB-END-MARKER*` (default `"%>"`)
End of scriptlet or expression.
## [special variable] `*ESCAPE-TYPE*`
Default value for escaping `@var` output is `:RAW` Can be changed to `:XML`,
`:HTML`, `:URI`, `:URL`, `:URL-ENCODE`, `:LATEX`.
## [special variable] `*FUNCTION-PACKAGE*`
Package the emb function body gets interned to.
Default: `(find-package :cl-emb-intern)`.
## [special variable] `*DEBUG*`
Debugging mode if `T`. Default: `NIL`.
## [special variable] `*LOCKING-FUNCTION*`
Function to call to lock access to an internal hash table. Must accept a
function designator which must be called with the lock hold.
**IMPORTANT:** The locking function must return the value of the function it
calls!
Example:
```lisp
(defvar *emb-lock* (kmrcl::make-lock "emb-lock")
"Lock for CL-EMB.")
(defun emb-lock-function (func)
"Lock function for CL-EMB."
(kmrcl::with-lock-held (*emb-lock*)
(funcall func)))
(setf emb:*locking-function* 'emb-lock-function)
```
Files get cached and reread when they change.
The emb code consists of normal text (HTML, XML, or any other text format) and
special tags you know from eRuby or JSP (JavaServer Pages) which can hold Common
Lisp or CL-EMB's template tags, perhaps comparable to JSP's taglib.
- `<% ... %>` is a scriptlet tag, and wraps Common Lisp code.
- `<%= ... %>` is an expression tag. Its content gets evaluated and fed as a
parameter to `(FORMAT T "~A" ...)`.
- `<%# ... #%>` is a comment. Everything within will be removed/ignored. Can't
be nested!
## Examples
```lisp
CL-USER> (asdf:oos 'asdf:load-op :cl-emb)
CL-USER> (cl-emb:register-emb "test1"
"10 stars: <% (dotimes (i 10) %>*<% ) %>")
#<CL-EMB::EMB-FUNCTION {9B74259}>
CL-USER> (cl-emb:execute-emb "test1")
"10 stars: **********"
CL-USER> (cl-emb:register-emb "test2" "2 + 2 = <%= (+ 2 2) %>")
#<CL-EMB::EMB-FUNCTION {9BCACE1}>
CL-USER> (cl-emb:execute-emb "test2")
"2 + 2 = 4"
CL-USER> (let ((emb:*emb-start-marker* "<?emb")
(emb:*emb-end-marker* "?>"))
(emb:register-emb "marker-test"
"42 + 42 = <?emb= (+ 42 42) ?>"))
#<CL-EMB::EMB-FUNCTION {97BEFD9}>
CL-USER> (emb:execute-emb "marker-test")
"42 + 42 = 84"
```
# Template Tags
You can use special template tags instead of Common Lisp code between `<%` and
`%>`. This will be translated to Common Lisp and serves as a simple shortcut for
you.
And more important: It's easier to use for non-programmers. A designer can work
on HTML code and insert these simple template tags.
Template tags start with `@`.
Currently supported: `@if`, `@else`, `@endif`, `@ifnotempty`, `@unless`,
`@endunless`, `@var`, `@repeat`, `@endrepeat`, `@loop`, `@endloop`, `@include`,
`@includevar`, `@call`, `@with`, `@endwith`, `@set`, `@genloop`, `@endgenloop`,
`@insert`.
`@if` and `@unless` check if the given parameter is set in the supplied
environment (parameter ENV of `EXECUTE-EMB`). The environment is a plist with
keyword + value pairs. Must be terminated with `@endif` or `@endunless`.
`@ifnotempty` works like `@if` but considers the empty string false.
`@ifequal` accepts two parameters interpreted as variable names. It works like
`@if` but checks whether the values of two variables are equal. Variable names
are intepreted as in `@var`.
Note that `@ifnotempty` and `@ifequal` are supposed to be used together with
`@else` and `@endif`.
`@var` emits the corresponding value from the environment. Uses the escape type
defined in `*ESCAPE-TYPE*` (Default `:raw`, no escaping) or with -escape
modifier. E.g. `<% @var foo -escape xml %>` or without modifier `<% @var foo
%>` Supported escaping: `raw`, `xml` (aka `html`), `uri` (aka `url` or
`url-encode`), `latex`.
`@insert` inserts a given (text) file. Parameter from the environment. E.g. `<%
@insert textfile %>`.
`@repeat` repeats everything between it and `@endrepeat` the given
times. Parameter can be a number or a name. The name will be used to lookup the
corresponding value from the environment.
`@loop` loops over a named list in the environment. Environment gets set to
current plist inside this list. Must be terminated with `@endloop`.
`@include` includes a given file. Relative to current template. `@includevar`
does the same, but the parameter is treated like a variable name containing the
path to the file. Variable name is treated like in `@var`.
`@call` calls a given emb-function, which was registered with `REGISTER-EMB`.
`@with` is similar to `@loop` as it sets the current environment to the named
plist. `@loop` needs a list of plists and `@with` just a plist associated to the
given name. Block ends in `@endwith`.
`@set` is used to set special variables like `*ESCAPE-TYPE*` from within a emb
code. This way a default for a file can be specified in the file itself. The
variables are changed for the current and called/included code. Changes to the
variables in called/included code don't effect the caller/ includer. E.g. `<%
@set escape=uri %>`. Currently supported: `escape` (`raw`, `xml`, `html`, `url`,
`uri`, `url-encode`, `latex`).
`@genloop` starts a special kind of loop: a generator loop. It must be
terminated by `@endgenloop` and operates on a generator returned by the given
`GENERATOR-MAKER` (see `EXECUTE-EMB`). The `GENERATOR-MAKER` gets called with
two parameters: the key (which is the argument to `@genloop`) and the
corresponding value in the plist. Each time in the loop the generator is called
first with the parameter `:TEST` to see if there's data left. The generator
must return a plist on `:NEXT`, which will be the current `ENV` (like `@with` or
within a normal `@loop`).
The parameters which access the environment can just be the name of a keyword
symbol in the plist. `foo` -> :FOO in `(:FOO "bar")` Or you can provide a path
within a nested plist structure by dividing the parts of the path with a
slash. `foo/bar` -> Value of `:BAR` inside the plist at `:FOO`. `(:FOO (:BAR
"yeah"))` -> `"yeah"` Starting the parameter with a slash lets it traverse the
nested plists from the top. That way you can access top values inside loops.
Writing `<% @var foo/bar/quux %>` can be translated to `(GETF (GETF (GETF ENV
:FOO) :BAR) :QUUX)`.
## Examples
```lisp
CL-USER> (cl-emb:register-emb "test1"
"Foo: <% @if foo %>Yes!<% @else %>No!<% @endif %>")
#<CL-EMB::EMB-FUNCTION {9C0F2D1}>
CL-USER> (cl-emb:execute-emb "test1" :env '(:foo t))
"Foo: Yes!"
CL-USER> (cl-emb:execute-emb "test1")
"Foo: No!"
CL-USER> (cl-emb:execute-emb "test1" :env '(:foo nil))
"Foo: No!"
CL-USER> (cl-emb:register-emb "test2"
"What is set? -> <% @call test1 %>")
#<CL-EMB::EMB-FUNCTION {9C526E9}>
CL-USER> (cl-emb:execute-emb "test2" :env '(:foo t))
"What is set? -> Foo: Yes!"
CL-USER> (cl-emb:register-emb "test3"
"10 stars: <% @repeat 10 %>*<% @endrepeat %>")
#<CL-EMB::EMB-FUNCTION {9C9F1D1}>
CL-USER> (cl-emb:execute-emb "test3")
"10 stars: **********"
CL-USER> (cl-emb:register-emb "test4"
"<% @loop numbers %>[<% @var de %>,<% @var en %>]<% @endloop %>")
#<CL-EMB::EMB-FUNCTION {9174DF1}>
CL-USER> (cl-emb:execute-emb "test4"
:env '(:numbers ((:de "EINS" :en "ONE")
(:de "ZWEI" :en "TWO"))))
"[EINS,ONE][ZWEI,TWO]"
CL-USER> (emb:register-emb "test5"
"<a href=\"http://somewhere.test/test.cgi?<% @var foo -escape uri %>\"><% @var foo %></a>")
#<CL-EMB::EMB-FUNCTION {9FBF5F1}>
CL-USER> (let ((emb:*escape-type* :html))
(emb:execute-emb "test5" :env '(:foo "10 > 7")))
"<a href=\"http://somewhere.test/test.cgi?10+%3E+7\">10 &gt; 7</a>"
CL-USER> (emb:register-emb "test6" "1. <% @with one %>BAZ: <% @var baz %><% @endwith%>
2. <% @with two %>BAZ: <% @var baz %><% @endwith%>")
#<CL-EMB::EMB-FUNCTION {9916EB1}>
CL-USER> (emb:execute-emb "test6" :env '(:one (:baz "first")
:two (:baz "second")))
"1. BAZ: first
2. BAZ: second"
CL-USER> (emb:register-emb "test7" " - <% @var foo -escape uri %> - ")
#<CL-EMB::EMB-FUNCTION {96F1239}>
CL-USER> (emb:pprint-emb-function "test7")
(LAMBDA (&OPTIONAL CL-EMB-INTERN::ENV)
(WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
(PROGN
(WRITE-STRING " - ")
(FORMAT T "~A" (CL-EMB::ECHO (GETF CL-EMB-INTERN::ENV :FOO) :ESCAPE :URI))
(WRITE-STRING " - "))))
; No value
CL-USER> (emb:register-emb "test8" "<% @set escape=xml %>--<% @var hey %>--")
#<CL-EMB::EMB-FUNCTION {962B839}>
CL-USER> (emb:register-emb "test9" "--<% @var hey %>--<% @call test8 %>--<% @var hey %>--")
#<CL-EMB::EMB-FUNCTION {96931A9}>
CL-USER> (emb:execute-emb "test9" :env '(:hey "5>2"))
"--5>2----5&gt;2----5>2--"
CL-USER> (emb:register-emb "test10" "Square root from 1 to <% @var numbers %>: <% @genloop numbers %>sqrt(<% @var number %>) = <% @var sqrt %> <% @endgenloop %>")
#<CL-EMB::EMB-FUNCTION {581EC765}>
CL-USER> (defun make-sqrt-1-to-n-gen (key n)
(declare (ignore key))
(let ((i 1))
#'(lambda (cmd)
(ecase cmd
(:test (> i n))
(:get `(:number ,i :sqrt ,(sqrt i)))
(:next (prog1 `(:number ,i :sqrt ,(sqrt i))
(unless (> i n)
(incf i))))))))
MAKE-SQRT-1-TO-N-GEN
CL-USER> (emb:execute-emb "test10" :env '(:numbers 10) :generator-maker 'make-sqrt-1-to-n-gen)
"Square root from 1 to 10: sqrt(1) = 1.0 sqrt(2) = 1.4142135 sqrt(3) = 1.7320508 sqrt(4) = 2.0 sqrt(5) = 2.236068 sqrt(6) = 2.4494898 sqrt(7) = 2.6457512 sqrt(8) = 2.828427 sqrt(9) = 3.0 sqrt(10) = 3.1622777 "
CL-USER> (emb:register-emb "test11" "<% @loop bands %>Band: <% @var band %> (Genre: <% @var /genre %>)<br><% @endloop %>")
#<CL-EMB::EMB-FUNCTION {58ADB12D}>
CL-USER> (emb:execute-emb "test11" :env '(:genre "Rock" :bands ((:band "Queen") (:band "The Rolling Stones") (:band "ZZ Top"))))
"Band: Queen (Genre: Rock)<br>Band: The Rolling Stones (Genre: Rock)<br>Band: ZZ Top (Genre: Rock)<br>"
CL-USER> (emb:register-emb "test12" "<% @repeat /foo/bar/count %>*<% @endrepeat %>")
#<CL-EMB::EMB-FUNCTION {58B7583D}>
CL-USER> (emb:execute-emb "test12" :env '(:foo (:bar (:count 42))))
"******************************************"
CL-USER> (emb:register-emb "test13" "The file:<pre><% @insert textfile %></pre>")
#<CL-EMB::EMB-FUNCTION {5894326D}>
CL-USER> (emb:execute-emb "test13" :env '(:textfile "/etc/gentoo-release"))
"The file:<pre>Gentoo Base System version 1.6.14
</pre>"
```
# Credits
Uses code from John Wiseman. See http://lemonodor.com/archives/000128.html and
lsp-LICENSE.txt Thanks to Edi Weitz for letting me use his code for
`ESCAPE-FOR-XML`.
Thanks to Eitarow Fukamachi for the whitespace-trimming patch.
Thanks to Christoph Finkensiep for making `getf*` a generic function.
# Author
Stefan Scholl <stesch@no-spoon.de>
# Current Maintainer
Michael Raskin <38a938c2@rambler.ru>

14
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/TODO Normal file
View file

@ -0,0 +1,14 @@
- Documentation
- More examples
- Tests
- Writing own escape functions?
- Better error handling
- Examples for generator loop in the examples.html
- Export GETF-EMB

26
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/cl-emb.asd Normal file
View file

@ -0,0 +1,26 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; This software is Copyright (c) Stefan Scholl, 2004.
;;; Stefan Scholl grants you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.
(in-package #:cl-user)
(defpackage #:cl-emb.system
(:use #:cl
#:asdf))
(in-package #:cl-emb.system)
(defsystem #:cl-emb
:version "0.4.3"
:author "Stefan Scholl <stesch@no-spoon.de>"
:licence "Lesser Lisp General Public License"
:description "A templating system for Common Lisp"
:depends-on (#:cl-ppcre)
:components ((:file "packages")
(:file "emb" :depends-on ("packages"))))

523
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/emb.lisp Normal file
View file

@ -0,0 +1,523 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; This file contains some fixes by Michael Raskin
;;; They are Copyright (c) Moscow Center of Continious Mathematical
;;; Education, 2009
;;; This software is Copyright (c) Stefan Scholl, 2004.
;;; Stefan Scholl grants you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.
;;; Parts of the source are taken from LSP, written by
;;; John Wiseman and copyright 2001, 2002 I/NET Inc.
;;; (http://www.inetmi.com/)
;;; See lsp-LICENSE.txt
(in-package :cl-emb)
(defpackage :cl-emb-intern (:use :cl))
(defvar *function-package* (find-package :cl-emb-intern)
"Package the emb function body gets interned to.")
(defvar *debug* nil
"Debugging for CL-EMB.")
(defvar *locking-function* nil
"Function to call to lock access to an internal hash table. Must accept
a function designator which must be called with the lock hold.")
(defmacro with-lock (&body body)
"Locking all accesses to *functions*"
`(cond (*locking-function*
(funcall *locking-function* #'(lambda () ,@body)))
(t ,@body)))
(defgeneric execute-emb (name &key env generator-maker)
(:documentation "Execute named emb code. Returns a string. Keyword parameter ENV
to pass objects to the code. ENV must be a plist."))
(defmethod execute-emb ((name t) &key env generator-maker)
(funcall (get-emb-function name) :env env :generator-maker generator-maker :name name))
(defmethod execute-emb ((name pathname) &key env generator-maker)
(let ((fun (or (get-emb-function name)
(emb-function-function (register-emb name name)))))
(funcall fun :env env :generator-maker generator-maker :name name)))
(defvar *functions* (make-hash-table :test #'equal)
"Table mapping names to emb-function instances.")
(defclass emb-function ()
((path :initarg :path
:accessor emb-function-path)
(time :initarg :time
:accessor emb-function-time)
(function :initarg :function
:accessor emb-function-function)
(form :initarg :form
:initform nil
:accessor emb-function-form)))
(defun make-emb-function (path time function &optional form)
"Constructor for class EMB-FUNCTION."
(make-instance 'emb-function
:path path
:time time
:function function
:form form))
(defun pprint-emb-function (name)
"DEBUG function. Pretty prints function form, if *DEBUG* was t
when the function was registered."
(with-lock
(pprint (emb-function-form (gethash name *functions*)))))
(defun clear-emb-all ()
"Remove all registered emb code."
(with-lock
(clrhash *functions*)))
(defun clear-emb (name)
"Remove named emb code."
(with-lock
(remhash name *functions*)))
(defun clear-emb-all-files ()
"Remove all registered file emb code (registered/executed by a pathname)."
(with-lock
(maphash (lambda (key value) (declare (ignore value))
(when (typep key 'pathname) (remhash key *functions*)))
*functions*)))
(defun get-emb-function (name)
"Returns the named function implementing a registered emb code.
Rebuilds it when text template was a file which has been modified."
(with-lock
(let* ((emb-function (gethash name *functions*))
(path (when emb-function (emb-function-path emb-function))))
(cond ((and (not (typep name 'pathname)) (null emb-function))
(error "Function ~S not found." name))
((null emb-function)
(return-from get-emb-function))
((and path
(> (file-write-date path) (emb-function-time emb-function)))
;; Update when file is newer
(multiple-value-bind (function form)
(construct-emb-function (contents-of-file path))
(setf (emb-function-time emb-function) (file-write-date path)
(emb-function-function emb-function) function
(emb-function-form emb-function) form))))
(emb-function-function emb-function))))
(defgeneric register-emb (name code)
(:documentation "Register given CODE as NAME."))
(defmethod register-emb (name (code pathname))
(multiple-value-bind (function form)
(construct-emb-function (contents-of-file code))
(with-lock
(setf (gethash name *functions*)
(make-emb-function code
(file-write-date code)
function
form)))))
(defmethod register-emb (name (code string))
(multiple-value-bind (function form)
(construct-emb-function code)
(with-lock
(setf (gethash name *functions*)
(make-emb-function nil
(get-universal-time)
function
form)))))
(defvar *emb-start-marker* "<%"
"Start of scriptlet or expression. Remember that a following #\=
indicates an expression.")
(defvar *emb-end-marker* "%>"
"End of scriptlet or expression.")
(defparameter *set-special-list*
'(("escape" . "cl-emb:*escape-type*")
("case-sensitivity" . "cl-emb:*case-sensitivity*")))
(defparameter *set-parameter-list*
'(("xml" . ":xml")
("html" . ":html")
("url" . ":url")
("uri" . ":uri")
("url-encode" . ":url-encode")
("raw" . ":raw")
("latex" . ":latex")
("t" . "t")
("nil" . "nil")))
;; TODO: Refactor! Looks a bit clumsy.
(defun set-specials (match &rest registers)
"Parse parameter(s) of @set and set special variables
like e. g. *ESCAPE-TYPE*."
;; <% @set escape=xml schnuffel=poe %>
(declare (ignore match))
(let ((setf-pairs
(let ((setf-list nil))
(dolist (pair (cl-ppcre:split "\\s+" (first registers))
(when (first setf-list)
(format nil "~{ ~A~}" (reverse setf-list))))
(destructuring-bind (left right)
(cl-ppcre:split "=" pair)
(let ((place (rest (assoc left *set-special-list* :test #'equalp)))
(value (rest (assoc right *set-parameter-list* :test #'equalp))))
(when (and place value)
(push (concatenate 'string place " " value) setf-list))))))))
(if setf-pairs
(format nil "(setf ~A)" setf-pairs)
"")))
(defparameter *template-tag-expand*
`(("\\s+@if\\s+(\\S+)\\s*" . " (cond ((cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) ")
("\\s+@ifnotempty\\s+(\\S+)\\s*" . " (cond ((let* ((value (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")))) (or (numberp value) (> (length value) 0))) ")
("\\s+@ifequal\\s+(\\S+)\\s+(\\S+)\\s*" . " (cond ((equal (format nil \"~a\" (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) (format nil \"~a\" (cl-emb::autofuncall (cl-emb::getf-emb \"\\2\")))) ")
("\\s+@else\\s*" . " ) (t ")
("\\s+@endif\\s*" . " )) ")
("\\s+@unless\\s+(\\S+)\\s*" . " (cond ((not (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) ")
("\\s+@endunless\\s*" . " )) ")
("=?\\s+@var\\s+(\\S+)\\s+-(\\S+)\\s+(\\S+)\\s*"
. "= (cl-emb::echo (cl-emb::getf-emb \"\\1\") :\\2 :\\3) ")
("=?\\s+@var\\s+(\\S+)\\s*" . "= (cl-emb::echo (cl-emb::getf-emb \"\\1\")) ")
("\\s+@repeat\\s+(\\d+)\\s*" . " (dotimes (i \\1) ")
("\\s+@repeat\\s+(\\S+)\\s*" . " (dotimes (i (or (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) 0)) ")
("\\s+@endrepeat\\s*" . " ) ")
("\\s+@loop\\s+(\\S+)\\s*" . " (dolist (env (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) ")
("\\s+@endloop\\s*" . " ) ")
("\\s+@genloop\\s+(\\S+)\\s*" . " (let ((env)
(%gen (funcall generator-maker :\\1
(cl-emb::getf-emb \"\\1\"))))
(loop
(when (funcall %gen :test) (return))
(setq env (funcall %gen :next))
(progn ")
("\\s+@endgenloop\\s*" . " ))) ")
("\\s+@with\\s+(\\S+)\\s*" . " (let ((env (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")))) ")
("\\s+@endwith\\s*" . " ) ")
("\\s+@include\\s+(\\S+)\\s*" . "= (let ((cl-emb:*escape-type* cl-emb:*escape-type*))
(cl-emb:execute-emb (merge-pathnames \"\\1\" template-path-default) :env env :generator-maker generator-maker)) ")
("\\s+@includevar\\s+(\\S+)\\s*" . "= (let* ((cl-emb:*escape-type* cl-emb:*escape-type*)
(parameter (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))))
(unless parameter (error \"use of @includevar on undefined parameter ~s\" \"\\1\"))
(cl-emb:execute-emb (merge-pathnames parameter template-path-default) :env env :generator-maker generator-maker)) ")
("\\s+@call\\s+(\\S+)\\s*" . "= (let ((cl-emb:*escape-type* cl-emb:*escape-type*))
(cl-emb:execute-emb \"\\1\" :env env :generator-maker generator-maker)) ")
("\\s+@insert\\s+(\\S+)\\s*" . "= (cl-emb::contents-of-file (merge-pathnames (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) template-path-default)) ")
("\\s+@set\\s+(.*?)\\s*" . ,(function set-specials))
("#.*" . "")
)
"List of conses. FIRST is regex, REST replacement (STRING or FUNCTION).
Functions get called with two parameters: match and list of registers.")
;; Code from Edi Weitz's TBNL <http://weitz.de/tbnl/>
(defun escape-for-xml (string)
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
do (case char
((#\<) (write-string "&lt;" out))
((#\>) (write-string "&gt;" out))
((#\") (write-string "&quot;" out))
((#\') (write-string "&#39;" out))
((#\&) (write-string "&amp;" out))
(otherwise (write-char char out)))))))
(defun escape-by-table (string replacements)
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
do (let ((new (find char replacements
:test 'equal
:key 'car)))
(if new
(write-string (cdr new) out)
(write-char char out))
)))))
(defvar *latex-replacements*)
(setf *latex-replacements*
(mapcar
(lambda (x) `(,(character (car x)) . ,(cdr x)))
`(
("#" . "\\#")
("$" . "\\$")
("%" . "\\%")
("&" . "\\&")
("_" . "\\_")
("{" . "\\{")
("}" . "\\}")
("<" . "{$<$}")
(">" . "{$>$}")
("\\" . "{$\\backslash{}$}")
("|" . "{$\\vert{}$}")
("~" . "{\\,$\\tilde{}$\\,}")
("^" . "{\\,$\\hat{}$\\,}")
(,(string #\Return) . "~\\\\")
(,(string #\NewLine) . "~\\\\")
("\"" . "{'{}'}")
(,(string (code-char 173)) . "\\-") ; Soft hyphen
(,(string (code-char 160)) . "~") ; No-break space
(,(string (code-char 8209)) . "-") ; Non-breaking hyphen
(,(string (code-char 8211)) . "--") ; En-dash
(,(string (code-char 8212)) . "---") ; Em-dash
(,(string (code-char 8470)) . "{\\textnumero}") ; Number sign
)))
(defun escape-for-latex (string)
(escape-by-table string
*latex-replacements*))
;; Inspired by Edi Weitz' ESCAPE-FOR-HTML
(defun url-encode (string)
"URL-encode a string."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
if (find char "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-.")
do (write-char char out)
else if (char= char #\Space)
do (write-char #\+ out)
else
do (format out "%~2,'0x" (char-code char))))))
(defvar *case-sensitivity* nil
"Whether use case-sensitive mode (the default) or case-insensitive mode. If this is set NIL, the case of keys in ENV will be ignored.")
(defun string-to-keyword (string)
"Interns a given STRING uppercased in the keyword package."
(nth-value 0 (intern
(if *case-sensitivity*
string
(string-upcase string)) :keyword)))
(defgeneric getf* (thing key &optional default)
(:documentation "Returns a value by a key"))
(defmethod getf* ((plist list) key &optional default)
"Uses getf to get a value from a plist"
(if *case-sensitivity*
(getf plist key default)
(loop for (k v) on plist by #'cddr
when (string-equal k key)
do (return v)
finally (return default))))
(defmethod getf* ((table hash-table) key &optional default)
"Uses gethash to get a value from a hash-table"
(gethash key table default))
(defmethod getf* ((object standard-object) key &optional default)
"Uses slot-value to get a value from a standard object, where the slot name is derived from key"
(let ((slot-name (intern (princ-to-string key)
(symbol-package (class-name (class-of object))))))
(if (and (slot-exists-p object slot-name)
(slot-boundp object slot-name))
(slot-value object slot-name)
default)))
(defmacro getf-emb (key)
"Search either plist TOPENV or ENV according to the search path in KEY. KEY
is a string."
(let ((plist (if (char= (char key 0) #\/)
(find-symbol "TOPENV" emb:*function-package*)
(find-symbol "ENV" emb:*function-package*)))
(path-parts (cl-ppcre:split "/" key :sharedp t)))
(labels ((dig-plist (plist keys)
(if (null keys)
plist
(dig-plist
(if (zerop (length (first keys)))
plist
`(getf* ,plist ,(string-to-keyword (first keys))))
(rest keys)))))
(dig-plist plist path-parts))))
(defvar *escape-type* :raw
"Default value for escaping @var output.")
(defun autofuncall (v)
(if (functionp v)
(autofuncall (funcall v))
v))
(defun echo (string &key (escape *escape-type*))
"Emit given STRING. Escape if wanted (global or via ESCAPE keyword).
STRING can be NIL."
(let ((str (cond
((stringp string) string)
((null string) "")
((functionp string)
(format nil "~a" (or (autofuncall string) "")))
(t (format nil "~a" string))
)))
(case escape
((:html :xml)
(escape-for-xml str))
((:latex)
(escape-for-latex str))
((:url :uri :url-encode)
(url-encode str))
(otherwise ; incl. :raw
str))))
(defun insert-file (filename)
"Get given file FILENAME."
(contents-of-file filename))
(let ((scanner-hash (make-hash-table :test #'equal)))
(defun scanner-for-expand-template-tag (tag)
"Returns a CL-PPCRE scanner which matches a template tag expanded by EXPAND-TEMPLATE-TAGS.
Scanners are memoized in SCANNER-HASH once they are created."
(or (gethash tag scanner-hash)
(setf (gethash tag scanner-hash)
(ppcre:create-scanner tag))))
(defun clear-expand-template-tag-hash ()
"Removes all scanners for template tags from cache."
(clrhash scanner-hash)))
(defun expand-template-tags (string)
"Expand template-tags (@if, @else, ...) to Common Lisp.
Replacement and regex in *TEMPLATE-TAG-EXPAND*"
(labels ((expand-tags (string &optional (expands *template-tag-expand*))
(let ((regex (scanner-for-expand-template-tag
(concatenate 'string "(?is)"
"^" (first (first expands)) "$")))
(replacement (rest (first expands))))
(if (null (rest expands))
(ppcre:regex-replace-all regex string replacement :simple-calls t)
(expand-tags
(ppcre:regex-replace-all regex string replacement :simple-calls t)
(rest expands))))))
(ppcre:regex-replace-all (format nil "(?is)(~A\\-?)(.+?)(\\-?~A)"
(ppcre:quote-meta-chars *emb-start-marker*)
(ppcre:quote-meta-chars *emb-end-marker*))
string
(lambda (match start-tag string end-tag)
(declare (ignore match))
(if (ppcre:scan "(?is)^#.+#$" string)
""
(concatenate 'string
start-tag
(expand-tags string)
end-tag)))
:simple-calls t)))
(defvar *emb-stream-redirection* "with-output-to-string (*standard-output*)")
(defun construct-emb-function (code)
"Builds and compiles the emb-function out of template code."
(let ((form
`,(let ((*package* *function-package*))
(read-from-string
(format nil "(lambda (&key env generator-maker name)(declare (ignorable env generator-maker))
(let ((topenv env)
(template-path-default (if (typep name 'pathname) name *default-pathname-defaults*)))
(declare (ignorable topenv template-path-default))
(~a
(progn ~A))))"
*emb-stream-redirection*
(construct-emb-body-string
(expand-template-tags code)))))))
(values (compile nil form)
(when *debug* form))))
(defun contents-of-file (pathname)
"Returns a string with the entire contents of the specified file."
(with-open-file (in pathname :direction :input)
;; See http://www.emmett.ca/~sabet/licensets/slurp.html
(let* ((file-length (file-length in))
(seq (make-string file-length))
(pos (read-sequence seq in)))
(if (< pos file-length)
(subseq seq 0 pos)
seq))))
(defun string-right-trim-spaces-until-newline (string)
(remove #\Newline (string-right-trim '(#\Space #\Tab) string)
:from-end t
:count 1))
;; (i) Converts text outside <% ... %> tags into calls
;; to WRITE-STRING, (ii) Text inside <% ... %>
;; ("scriptlets") is straight lisp code, (iii) Text inside <%= ... %>
;; ("expressions") becomes the argument to (FORMAT t "~A" ...)
;; The markers <% and %> can be overridden by setting
;; *emb-start-marker* and *emb-end-marker*
(defun construct-emb-body-string (code &optional (start 0))
"Takes a string containing an emb code and returns a string
containing the lisp code that implements that emb code."
(multiple-value-bind (start-tag start-code tag-type trim-start-whitespaces)
(next-code code start)
(if (not start-tag)
(format nil "(write-string ~S)" (subseq code start))
(let* ((end-code (search *emb-end-marker* code :start2 start-code))
(trim-end-whitespaces (char= (char code (1- end-code)) #\-)))
(if (not end-code)
(error "EOF reached in EMB inside open '~A' tag." *emb-start-marker*)
(format nil "(write-string ~S) ~A ~A"
(if trim-start-whitespaces
(string-right-trim-spaces-until-newline (subseq code start start-tag))
(subseq code start start-tag))
(format nil (tag-template tag-type)
(subseq code start-code (if trim-end-whitespaces
(1- end-code)
end-code)))
(construct-emb-body-string
code
(if trim-end-whitespaces
(let ((next-pos (cl-ppcre:scan "(?:\\S|\\n)" code :start (+ end-code (length *emb-end-marker*)))))
(cond
((null next-pos) (length code))
((char= (elt code next-pos) #\Newline)
(1+ next-pos))
(t next-pos)))
(+ end-code (length *emb-end-marker*))))))))))
;; Finds the next scriptlet or expression tag in EMB source. Returns
;; nil if none are found, otherwise returns 3 values:
;; 1. The position of the first character of the start tag.
;; 2. The position of the contents of the tag.
;; 3. The type of tag (:scriptlet or :expression).
;; 4. Whether trim whitespaces before the start tag.
(defun next-code (string start)
(let ((start-tag (search *emb-start-marker* string :start2 start)))
(if (not start-tag)
nil
(let ((start-code (+ start-tag (length *emb-start-marker*))))
(case (and (> (length string) start-code)
(char string start-code))
(#\= (values start-tag (1+ start-code) :expression nil))
(#\- (values start-tag (1+ start-code) :scriptlet t))
(otherwise (values start-tag start-code :scriptlet nil)))))))
;; Given a tag type (:scriptlet or :expression), returns a format
;; string to be used to generate source code from the contents of the
;; tag.
(defun tag-template (tag-type)
(ecase tag-type
((:scriptlet) "~A")
((:expression) "(format t \"~~A\" ~A)")))

18
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/examples.css Normal file
View file

@ -0,0 +1,18 @@
body { font-family: sans-serif;
background-color: #fff;
color: #000; }
pre { margin-top: 0;
margin-bottom: 0; }
table { width: 100%; }
th, td { text-align: left;
vertical-align: top; }
th { background-color: #eee; }
caption { font-weight: bold; }
table, ol { margin-bottom: 2em; }

232
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/examples.html Normal file
View file

@ -0,0 +1,232 @@
<?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">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<link href="examples.css" rel="stylesheet" type="text/css" />
<title>CL-EMB: Examples</title>
</head>
<body>
<h1>Some examples of <a href="http://common-lisp.net/project/cl-emb/">CL-EMB</a> usage</h1>
<ol>
<li><a href="#combine-cl-who">Combining CL-EMB with CL-WHO</a></li>
<li><a href="#simple-loop">A simple loop</a></li>
<li><a href="#build-dropdown">Build a dropdown</a></li>
<li><a href="#mark-fields">Mark invalid form fields</a></li>
<li><a href="#using-generic-templates">Using generic templates</a></li>
</ol>
<table border="1" cellpadding="2" id="combine-cl-who">
<caption>Combining CL-EMB with CL-WHO</caption>
<tr>
<th>
Description
</th>
<td>
You can mix several methods of HTML generating together. Think of <a href="http://www.cliki.net/Lisp%20Markup%20Languages">Lisp Markup Languages</a> like <a href="http://weitz.de/cl-who/">CL-WHO</a>. <small>(Example code from the <a href="http://weitz.de/cl-who/">CL-WHO</a> documentation.)</small>
</td>
</tr>
<tr>
<th>
ENV
</th>
<td>
<code>NIL</code>
</td>
</tr>
<tr>
<th>
Dependencies
</th>
<td>
<a href="http://weitz.de/cl-who/">CL-WHO</a>
</td>
</tr>
<tr>
<td colspan="2">
<pre>&lt;h1&gt;Music links&lt;/h1&gt;
&lt;%
(cl-who:with-html-output (*standard-output*)
(loop for (link . title) in
'((&quot;http://zappa.com/&quot; . &quot;Frank Zappa&quot;)
(&quot;http://marcusmiller.com/&quot; . &quot;Marcus Miller&quot;)
(&quot;http://www.milesdavis.com/&quot; . &quot;Miles Davis&quot;))
do (cl-who:htm (:a :href link
(:b (cl-who:str title)))
:br)))
%&gt;</pre>
</td>
</tr>
</table>
<table border="1" cellpadding="2" id="simple-loop">
<caption>A simple loop</caption>
<tr>
<th>
Description
</th>
<td>
The "Music links" example with template tags and a loop. This example isn't meant to prove anything! Use the method which fits your problem!<br/>
The output of the title gets escaped by CL-EMB ("-escape html"). Depending on the situation you'd rather escape the output yourself and don't want to use any complicated modifiers in the template code itself.
</td>
</tr>
<tr>
<th>
ENV
</th>
<td>
<pre>'(:music-list
((:link "http://zappa.com/" :title "Frank Zappa")
(:link "http://marcusmiller.com/" :title "Marcus Miller")
(:link "http://www.milesdavis.com/" :title "Miles Davis")))</pre>
</td>
</tr>
<tr>
<th>
Dependencies
</th>
<td>
-
</td>
</tr>
<tr>
<td colspan="2">
<pre>&lt;h1&gt;Music links&lt;/h1&gt;
&lt;% @loop music-list %&gt;
&lt;a href=&quot;&lt;% @var link %&gt;&quot;&gt;&lt;b&gt;&lt;% @var title -escape html%&gt;&lt;/b&gt;&lt;/a&gt;&lt;br /&gt;
&lt;% @endloop %&gt;</pre>
</td>
</tr>
</table>
<table border="1" cellpadding="2" id="build-dropdown">
<caption>Build a dropdown</caption>
<tr>
<th>
Description
</th>
<td>
You can mix template style with embedded Common Lisp style. This example shows how to access the plist ENV. Within the loop (<code >@loop</code>) ENV gets bound to every plist in the list.<br/>
<a href="http://weitz.de/tbnl/">TBNL</a> is used to access a submitted parameter "product" and compare it to the current value attribute of the option element.<br/>
Remember the escaping! Set <code>cl-emb:*escape-type*</code> to <code>:html</code> and all output of <code>@var</code> will be escaped correctly.
</td>
</tr>
<tr>
<th>
ENV
</th>
<td>
<pre>'(:products
((:value "foo1" :text "Super Foo")
(:value "fooxl" :text "Super Foo XL")
(:value "bar2000" :text "Ultra Bar 2000")
(:value "hl2" :text "Half-Life 2")
(:value "dn4e4" :text "Vaporware")))</pre>
</td>
</tr>
<tr>
<th>
Dependencies
</th>
<td>
<a href="http://weitz.de/tbnl/">TBNL</a>
</td>
</tr>
<tr>
<td colspan="2">
<pre>&lt;select name=&quot;product&quot;&gt;
&lt;% @loop products %&gt;
&lt;option value=&quot;&lt;% @var value %&gt;&quot;&lt;%
(when (equal (getf env :value) (tbnl:parameter &quot;product&quot;))
%&gt; selected=&quot;selected&quot;&lt;% ) %&gt;&gt;&lt;% @var text %&gt;&lt;/option&gt;
&lt;% @endloop %&gt;
&lt;/select&gt;</pre>
</td>
</tr>
</table>
<table border="1" cellpadding="2" id="mark-fields">
<caption>Mark invalid form fields</caption>
<tr>
<th>
Description
</th>
<td>
Validate a form and mark the errors in the <em>ENV</em> plist.<br />
Again: Remember the escaping!
</td>
</tr>
<tr>
<th>
ENV
</th>
<td>
<pre>'(:email "stesch@home" :email-error t)</pre>
</td>
</tr>
<tr>
<th>
Dependencies
</th>
<td>
-
</td>
</tr>
<tr>
<td colspan="2">
<pre>&lt;% @if email-error %&gt;
&lt;span class=&quot;error&quot;&gt;Please provide valid e-mail address&lt;/span&gt;&lt;br /&gt;
&lt;% @endif %&gt;
&lt;input type=&quot;text&quot; name=&quot;email&quot; value=&quot;&lt;% @var email %&gt;&quot;/&gt;</pre>
</td>
</tr>
</table>
<table border="1" cellpadding="2" id="using-generic-templates">
<caption>Using generic templates</caption>
<tr>
<th>
Description
</th>
<td>
You want to use generic templates which can be called with a defined set of parameters? Then <code>@with</code> and <code>@endwith</code> is what you are looking for. It sets the current <em>ENV</em> to the one accessed by a given name. See the example below, which calls a template for textinput fields.
</td>
</tr>
<tr>
<th>
ENV
</th>
<td>
<pre>'(:name (:name "name"
:length 40)
:e-mail (:name "email"
:value "no@no"
:error t
:length 120))</pre>
</td>
</tr>
<tr>
<th>
Dependencies
</th>
<td>
-
</td>
</tr>
<tr>
<td colspan="2">
<pre>Please enter your name:&lt;br /&gt;
&lt;% @with name %&gt;
&lt;% @include &quot;includes/textinput.tmpl&quot; %&gt;
&lt;% @endwith %&gt;
&lt;br /&gt;
Please enter your e-mail address:&lt;br /&gt;
&lt;small&gt;(Use the TLD &lt;em&gt;.invalid&lt;/em&gt;
if you don't want to receive mail&lt;/small&gt;
&lt;% @with e-mail %&gt;
&lt;% @include &quot;includes/textinput.tmpl&quot; %&gt;
&lt;% @endwith %&gt;</pre>
</td>
</tr>
</table>
</body>
</html>

27
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/lsp-LICENSE.txt Normal file
View file

@ -0,0 +1,27 @@
CL-EMB uses parts of LSP, written by John Wiseman.
See the copyright notice and license for LSP:
---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---
Copyright (c) 2001, 2002 I/NET Inc.
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.

31
sbcl/.quicklisp/dists/quicklisp/software/cl-emb-20190521-git/packages.lisp Normal file
View file

@ -0,0 +1,31 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; This software is Copyright (c) Stefan Scholl, 2004.
;;; Stefan Scholl grants you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.
(in-package #:cl-user)
(defpackage #:cl-emb
(:nicknames #:emb)
(:use #:cl)
(:export #:execute-emb
#:register-emb
#:pprint-emb-function
#:clear-emb
#:clear-emb-all
#:clear-emb-all-files
#:clear-expand-template-tag-hash
#:*debug*
#:*emb-start-marker*
#:*emb-end-marker*
#:*escape-type*
#:*case-sensitivity*
#:*locking-function*
#:*function-package*
#:getf*
#:construct-emb-function ))

121
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/CHANGELOG Normal file
View file

@ -0,0 +1,121 @@
Version 0.7.6
2019-07-28
Clisp has renamed ext:delete-dir to ext:delete-directory.
Fix get-default-temporary-directory on lispworks.
Version 0.7.5
2017-12-10
Fix FILE-EXISTS-P to return directory truename in CLISP (chaitanyagupta)
Added support for Common Lisp implementation CLASP. (dg1sbg)
Version 0.7.4
2016-07-10
Merge pull request #13 from vibs29/master (Hans Hübner)
Make copy-stream work for CMUCL Gray Streams (vibs29)
Version 0.7.3
2014-11-28
remove version from cl-fad-test system (Hans Huebner)
update support information (Hans Huebner)
Version 0.7.2
2013-07-03
Fix documentation glitch (inconsistent download link) (Luís Oliveira)
Version 0.7.1
2013-02-18
Fix for LispWorks (R. Wilker)
Add :description to .asd file
Version 0.7.0
2013-01-23
Tests, pathname manipulation functions (Marco Baringer)
Temporary files (merged by Marco Baringer)
Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins)
Version 0.6.4
2010-11-18
Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)
Version 0.6.3
2009-09-30
Removed dependency on :SB-EXECUTABLE (thanks to Attila Lendvai and Tobias Rittweiler)
Version 0.6.2
2008-03-12
Never version of OpenMCL have %RMDIR (thanks to Dmitri Hrapof)
Version 0.6.1
2007-12-29
Integrated CLISP patch for LIST-DIRECTORY sent by Dan Muller
Version 0.6.0
2007-05-28
Support for Scieneer CL (patch from Douglas Crosher)
Version 0.5.2
2007-05-15
Fix for (newer versions of) ECL (patch from Dustin Long)
Version 0.5.1
2006-08-11
Added CHECKP to COPY-STREAM
Version 0.5.0
2006-04-21
Added :BREADTH-FIRST option to WALK-DIRECTORY (thanks to Mac Chan)
Version 0.4.3
2006-03-15
For CMUCL use TRUENAME with UNIX-RMDIR to cope with search lists (reported by Pawel Ostrowski)
Version 0.4.2
2006-01-04
WALK-DIRECTORY now catches circular symbolic links (thanks to Gary King)
Version 0.4.1
2006-01-03
Be more careful in DIRECTORY-WILDCARD (thanks to Gary King)
Patches for MCL (thanks to Gary King)
Version 0.4.0
2005-12-10
Exported COPY-STREAM (suggested by Chris Dean)
Version 0.3.3
2005-11-14
Fixed %RMDIR for newer versions of OpenMCL (thanks to James Bielman)
Version 0.3.2
2005-09-11
Fixed docs (correct name DELETE-DIRECTORY-AND-FILES)
Fixed docs (OVERWRITE was missing in COPY-FILE signature)
Added Debian link
Version 0.3.1
2005-06-02
Fixed typo in fad.lisp (thanks to Jack D. Unrue)
Version 0.3.0
2005-06-01
Support for ABCL (thanks to Jack D. Unrue)
Version 0.2.0
2005-05-29
Support for ECL (thanks to Maciek Pasternacki)
Version 0.1.3
2005-04-27
Changed implementation of DIRECTORY-EXISTS-P for LispWorks
Version 0.1.2
2005-03-17
Fixed typo in cl-fad.system (tanks to Andrew Philpot)
Version 0.1.1
2005-01-22
Fixed typos and versioning
Version 0.1.0
2005-01-22
Initial release

26
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/LICENSE Normal file
View file

@ -0,0 +1,26 @@
;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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 AUTHORS '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.

38
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/README Normal file
View file

@ -0,0 +1,38 @@
Complete documentation for CL-FAD can be found in the 'docs'
directory or at <https://edicl.github.io/cl-fad/>.
CL-FAD also supports Nikodemus Siivola's HYPERDOC, see
<http://common-lisp.net/project/hyperdoc/> and
<http://www.cliki.net/hyperdoc>.
1. Installation
1.1. Probably the easiest way is
(load "/path/to/cl-fad/load.lisp")
This should compile and load CL-FAD on most Common Lisp
implementations.
1.2. With MK:DEFSYSTEM you can make a symbolic link from
'cl-fad.system' and 'cl-fad-test.system' to your central registry
(which by default is in '/usr/local/lisp/Registry/') and then issue
the command
(mk:compile-system "cl-fad")
Note that this relies on TRUENAME returning the original file a
symbolic link is pointing to. This will only work with AllegroCL
6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO).
1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way
(use the .asd files instead of the .system files).
1.4. Via QuickLisp:
(ql:quickload :cl-fad)
2. Test
CL-FAD comes with a small test suite. To start it just load the file
"test.lisp" and evaluate (CL-FAD-TEST:TEST).

50
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/cl-fad.asd Normal file
View file

@ -0,0 +1,50 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.asd,v 1.21 2009/09/30 14:23:09 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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.
#+:allegro (cl:require :osi)
(asdf:defsystem #:cl-fad
:version "0.7.6"
:description "Portable pathname library"
:serial t
:license "BSD-2-Clause"
:components ((:file "packages")
#+:cormanlisp (:file "corman")
#+:openmcl (:file "openmcl")
(:file "fad")
(:file "path" :depends-on ("fad"))
(:file "temporary-files" :depends-on ("fad")))
:depends-on (#+sbcl :sb-posix :bordeaux-threads :alexandria))
(asdf:defsystem #:cl-fad-test
:serial t
:components ((:file "packages.test")
(:file "fad.test" :depends-on ("packages.test"))
(:file "temporary-files.test" :depends-on ("packages.test")))
:depends-on (:cl-fad :unit-test :cl-ppcre))

48
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/cl-fad.system Normal file
View file

@ -0,0 +1,48 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.system,v 1.8 2008/03/12 00:10:43 edi Exp $
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. 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.
(in-package #:cl-user)
(defparameter *cl-fad-base-directory*
(make-pathname :name nil :type nil :version nil
:defaults (parse-namestring *load-truename*)))
#+:allegro (require :osi)
#+:sbcl (require :sb-executable)
#+:sbcl (require :sb-posix)
(mk:defsystem #:cl-fad
:source-pathname *cl-fad-base-directory*
:source-extension "lisp"
:components ((:file "packages")
#+:cormanlisp (:file "corman" :depends-on ("packages"))
#+:openmcl (:file "openmcl" :depends-on ("packages"))
(:file "fad" :depends-on ("packages"
#+:cormanlisp "corman"
#+:openmcl "openmcl"))))

86
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/corman.lisp Normal file
View file

@ -0,0 +1,86 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/corman.lisp,v 1.5 2009/09/30 14:23:09 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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 AUTHORS '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.
(in-package :cl)
(defun wild-pathname-p (pathspec &optional field)
(unless (pathnamep pathspec)
(setq pathspec (pathname pathspec)))
(labels ((name-wild-p (name)
(or (eq :wild name)
(and (stringp name)
(string= "*" name))))
(dir-wild-p (dir)
(or (find :wild dir)
(find :wild-inferiors dir)
(find "*" dir :test #'string=))))
(case field
((:name)
(name-wild-p (pathname-name pathspec)))
((:type)
(name-wild-p (pathname-type pathspec)))
((:directory)
(dir-wild-p (pathname-directory pathspec)))
((nil)
(or (name-wild-p (pathname-name pathspec))
(name-wild-p (pathname-type pathspec))
(dir-wild-p (pathname-directory pathspec))))
(t nil))))
(defun file-namestring (pathspec)
(flet ((string-list-for-component (component)
(cond ((eq component :wild)
(list "*"))
(component
(list component))
(t nil))))
(let* ((pathname (pathname pathspec))
(name (pathnames::pathname-internal-name pathname))
(type (pathnames::pathname-internal-type pathname)))
(format nil "~{~A~}~{.~A~}"
(string-list-for-component name)
(string-list-for-component type)))))
(in-package :win32)
(defwinapi RemoveDirectory
((lpPathName LPCSTR))
:return-type BOOL
:library-name "Kernel32"
:entry-name "RemoveDirectoryA"
:linkage-type :pascal)
(defun delete-directory (pathspec)
"Deletes the empty directory denoted by the pathname designator
PATHSPEC. Returns true if successful, NIL otherwise."
(win:RemoveDirectory
(ct:lisp-string-to-c-string
(namestring (pathname pathspec)))))
(export 'delete-directory)

700
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/docs/index.html Normal file
View file

@ -0,0 +1,700 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<title>CL-FAD - A portable pathname library for Common Lisp</title>
<style type="text/css">
pre { padding:5px; background-color:#e0e0e0 }
h3, h4, h5 { text-decoration: underline; }
a { text-decoration: none; padding: 1px 2px 1px 2px; }
a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
a.none { text-decoration: none; padding: 0; }
a.none:visited { text-decoration: none; padding: 0; }
a.none:hover { text-decoration: none; border: none; padding: 0; }
a.none:focus { text-decoration: none; border: none; padding: 0; }
a.noborder { text-decoration: none; padding: 0; }
a.noborder:visited { text-decoration: none; padding: 0; }
a.noborder:hover { text-decoration: none; border: none; padding: 0; }
a.noborder:focus { text-decoration: none; border: none; padding: 0; }
pre.none { padding:5px; background-color:#ffffff }
</style>
</head>
<body bgcolor=white>
<h2>CL-FAD - A portable pathname library for Common Lisp</h2>
<blockquote>
<br>&nbsp;<br><h3><a name=abstract class=none>Abstract</a></h3>
CL-FAD (for "<font color=red>F</font>iles <font color=red>a</font>nd
<font color=red>D</font>irectories") is a thin layer atop Common
Lisp's standard pathname functions. It is intended to provide some
unification between current CL implementations on Windows, OS X,
Linux, and Unix. Most of the code was written by Peter Seibel for his book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common Lisp</em></a>.
<p>
CL-FAD comes with a <a
href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
license</a> so you can basically do with it whatever you want.
<p>
<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>.
</blockquote>
<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
<ol>
<li><a href="#download">Download and installation</a>
<li><a href="#implementations">Supported Lisp implementations</a>
<li><a href="#dictionary">The CL-FAD dictionary</a>
<ol>
<li><a href="#querying">Querying files, directories and pathnames</a>
<ol>
<li><a href="#directory-exists-p"><code>directory-exists-p</code> [function]</a>
<li><a href="#directory-pathname-p"><code>directory-pathname-p</code> [function]</a>
<li><a href="#file-exists-p"><code>file-exists-p</code> [function]</a>
<li><a href="#pathname-absolute-p"><code>pathname-absolute-p</code> [function]</a>
<li><a href="#pathname-equal"><code>pathname-equal</code> [function]</a>
<li><a href="#pathname-relative-p"><code>pathname-relative-p</code> [function]</a>
<li><a href="#pathname-root-p"><code>pathname-root-p</code> [function]</a>
</ol> </li>
<li><a href="#manipulating">Manipulating pathnames</a>
<ol>
<li><a href="#canonical-pathname"><code>canonical-pathname</code> [function]</a>
<li><a href="#merge-pathnames-as-directory"><code>merge-pathnames-as-directory</code> [function]</a>
<li><a href="#merge-pathnames-as-file"><code>merge-pathnames-as-file</code> [function]</a>
<li><a href="#pathname-as-directory"><code>pathname-as-directory</code> [function]</a>
<li><a href="#pathname-as-file"><code>pathname-as-file</code> [function]</a>
<li><a href="#pathname-directory-pathname"><code>pathname-directory-pathname</code> [function]</a>
<li><a href="#pathname-parent-directory"><code>pathname-parent-directory</code> [function]</a>
</ol> </li>
<li><a href="#traversing">Traversing directories</a>
<ol>
<li><a href="#list-directory"><code>list-directory</code> [function]</a>
<li><a href="#walk-directory"><code>walk-directory</code> [function]</a>
</ol> </li>
<li><a href="#temporary-files">Temporary Files</a>
<ol>
<li><a href="#open-temporary"><code>open-temporary</code> [function]</a>
<li><a href="#with-output-to-temporary-file"><code>with-output-to-temporary-file</code> [macro]</a>
<li><a href="#with-open-temporary-file"><code>with-open-temporary-file</code> [macro]</a>
<li><a href="#star-default-template-star"><code>*default-template*</code> [variable]</a>
<li><a href="#cannot-create-temporary-file"><code>cannot-create-temporary-file</code> [condition]</a>
<li><a href="#invalid-temporary-pathname-template"><code>invalid-temporary-pathname-template</code> [condition]</a>
<li><a href="#missing-temp-environment-variable"><code>missing-temp-environment-variable</code> [condition]</a>
<li><a href="#lp-host-temporary-files"><code>temporary-files</code> [logical pathname host]</a>
</ol>
</li>
<li><a href="#modifying">Modifying the file system</a>
<ol>
<li><a href="#copy-file"><code>copy-file</code> [function]</a>
<li><a href="#copy-stream"><code>copy-stream</code> [function]</a>
<li><a href="#delete-directory-and-files"><code>delete-directory-and-files</code> [function]</a>
</ol> </li>
<li><a href="#package-path"><code>path</code> [package]</a>
</ol>
<li><a href="#ack">Acknowledgements</a>
</ol>
<br>&nbsp;<br><h3><a class=none name="download">Download and installation</a></h3>
CL-FAD together with this documentation can be downloaded from <a
href="https://github.com/edicl/cl-fad/releases/latest">https://github.com/edicl/cl-fad/releases/latest</a>. The
current version is 0.7.6.
<p>
CL-FAD comes with simple system definitions for <a
href="http://www.cliki.net/mk-defsystem">MK:DEFSYSTEM</a> and <a
href="http://www.cliki.net/asdf">asdf</a> so you can either adapt it
to your needs or just unpack the archive and from within the CL-FAD
directory start your Lisp image and evaluate the form
<code>(mk:compile-system&nbsp;&quot;cl-fad&quot;)</code> - or <code>(asdf:oos&nbsp;'asdf:load-op&nbsp;:cl-fad)</code> for asdf - which should compile and load the whole
system.
Installation via <a
href="http://www.cliki.net/asdf-install">asdf-install</a> should as well
be possible. Plus, there are ports
for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy
and for <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-fad&amp;searchon=names&amp;subword=1&amp;version=all&amp;release=all">Debian Linux</a> thanks to Ren&eacute; van Bevern.
<p>
If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you
can just <code>LOAD</code> the file <code>load.lisp</code>.
<p>
The latest version of the source code lives in the github repository <a href="https://github.com/edicl/cl-fad">edicl/cl-fad</a>.
If you want to send patches,
please <a href="http://weitz.de/patches.html">read this first</a>.
Please submit your changes
as <a href="https://github.com/edicl/cl-fad/pulls">GitHub pull
request"</a>.
<br>&nbsp;<br><h3><a class=none name="implementations">Supported Lisp implementations</a></h3>
<p>
The following Common Lisp implementations are currently supported:
<ul>
<li><a href="http://armedbear.org/abcl.html">Armed Bear Common Lisp</a>
<li><a href="http://www.cons.org/cmucl/">CMUCL</a>
<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>
<li><a href="http://ecls.sf.net/">ECL</a>
<li><a href="http://www.franz.com/products/allegrocl/">Franz AllegroCL</a>
<li><a href="http://clisp.cons.org/">GNU CLISP</a>
<li><a href="http://www.lispworks.com/">LispWorks</a>
<li><a href="http://www.digitool.com/">Macintosh Common Lisp</a>
<li><a href="http://openmcl.clozure.com/">OpenMCL</a>
<li><a href="http://www.scieneer.com/scl/">Scieneer Common Lisp</a>
<li><a href="http://sbcl.sourceforge.net/">Steel Bank Common Lisp</a>
</ul>
I'll gladly accepts patches to make CL-FAD work on other platforms.
<br>&nbsp;<br><h3><a class=none name="dictionary">The CL-FAD dictionary</a></h3>
<h4><a class=none name="querying">Querying files, directories and pathnames</a></h4>
<p><br>[Function]
<br><a class=none name="directory-exists-p"><b>directory-exists-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
<blockquote><br>
Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
exists and if it is a directory. Returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the
case, <code>NIL</code> otherwise. The truename is returned in <em>directory form</em> as if
by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
</blockquote>
<p><br>[Function]
<br><a class=none name="directory-pathname-p"><b>directory-pathname-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
<blockquote><br>
Returns <code>NIL</code> if <code><i>pathspec</i></code> (a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a>) does not designate
a directory, <code><i>pathspec</i></code> otherwise. It is irrelevant whether the file or
directory designated by <code><i>pathspec</i></code> does actually exist.
</blockquote>
<p><br>[Function]
<br><a class=none name="file-exists-p"><b>file-exists-p</b> <i> pathspec </i> =&gt; <i> generalized-boolean</i></a>
<blockquote><br>
Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
exists and returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the case, <code>NIL</code> otherwise.
The truename is returned in "canonical" form, i.e. the truename of a
directory is returned in <em>directory form</em> as if by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-absolute-p'><b>pathname-absolute-p</b> <i>a</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns true if <code><i>a</i></code> is an absolute pathname. This simply
tests if <code><i>a</i></code>&#039;s directory list starts with <code>:ABSOLUTE</code></p>
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-equal'><b>pathname-equal</b> <i>a b</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns <em>true</em> if <code><i>a</i></code> and <code><i>b</i></code>
represent the same pathname. This function does not access the
filesystem, it only looks at the components of the two pathnames to
test if they are the same (though by passing both <code><i>a</i></code>
and <code><i>b</i></code> to probe-file one can make this function test for
file &#039;sameness&#039;.</p>
<p>Equality is defined as:</p>
<ul>
<li>strings that are <code>string=</code>
<li>symbols (including <code>nil</code> and keywords) which are <code>eql</code>
<li>lists of the same length with equal (as per these rules) elements.
</ul>
<p>If any of these tree conditions is false for any of the components in
<code><i>a</i></code> and <code><i>b</i></code> then <code><i>a</i></code>
and <code><i>b</i></code> are different, otherwise they are the same.</p>
<p><em>NB:</em> This function does not convert name strings to pathnames. So
&quot;foo.txt&quot; and #P&quot;foo.txt&quot; are different pathnames.</p>
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-relative-p'><b>pathname-relative-p</b> <i>a</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns true if <code><i>a</i></code> is a relative pathname. This simply
tests if <code><i>a</i></code>&#039;s directory starts
with <code>:RELATIVE</code>.</p>
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-root-p'><b>pathname-root-p</b> <i>a</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns <em>true</em> if <code><i>pathname</i></code> is the root
directory (in other words, a directory which is its own parent).</p>
</blockquote>
<h4><a class=none name="manipulating">Manipulating pathnames</a></h4>
<p><br>[Function]<br><a class=none name='canonical-pathname'><b>canonical-pathname</b> <i>pathname</i> =&gt; <i>result</i></a>
<blockquote>
<p>Remove redundant information from PATHNAME.</p>
<p>This simply walks down <code>PATHNAME</code>&#039;s
pathname-directory and drops &quot;.&quot; directories, removes :back
and its preceding element.</p>
<p>NB: This function does not access the filesystem, it only looks at the
values in the pathname and works on their known (or assumed)
meanings.</p>
<p>NB: Since this function does not access the filesystem it will only
remove <code>:BACK</code> elements from the path (not <code>:UP</code>
elements). Since some lisps, ccl/sbcl/clisp convert &quot;..&quot; in
pathnames to <code>:UP</code>, and not <code>:BACK</code>, the actual
utility of the function is limited.</p>
</blockquote>
<p><br>[Function]<br><a class=none name='merge-pathnames-as-directory'><b>merge-pathnames-as-directory</b> <i><tt>&amp;rest</tt> pathnames</i> =&gt; <i>result</i></a>
<blockquote>
<p>Given a list of (probably relative) pathnames, this returns a single
directory pathname containing the logical concatenation of them all.</p>
<p>The returned value is the current directory if one were to cd into
each of <code><i>pathnames</i></code> in order. For this reason an
absolute pathname will, effectively, cancel the affect of any previous
relative pathnames.</p>
<p>The returned value&#039;s defaults are taken from the first element of
<code><i>pathnames</i></code> (host, version and device).</p>
<p><em>NB:</em> Since this function only looks at directory names the name and
type of the elements of <code><i>pathnames</i></code> are ignored. Make sure to properly
use either trailing #\/s, or <a href="#pathname-as-directory">pathname-as-directory</a>, to get the
expected results.</p>
<p>Examples:</p>
<pre>
(merge-pathnames-as-directory #P&quot;foo/&quot; #P&quot;bar/&quot;) == #P&quot;foo/bar/&quot;
(merge-pathnames-as-directory #P&quot;foo/&quot; #P&quot;./bar/&quot;) == #P&quot;foo/./bar/&quot;
(merge-pathnames-as-directory #P&quot;foo/&quot; #P&quot;/bar/&quot;) == #P&quot;/bar/&quot;
(merge-pathnames-as-directory #P&quot;foo/&quot; #P&quot;/bar/&quot; #P&#039;quux/file.txt) == #P&quot;/bar/quux/&quot;
</pre>
</blockquote>
<p><br>[Function]<br><a class=none name='merge-pathnames-as-file'><b>merge-pathnames-as-file</b> <i><tt>&amp;rest</tt> pathnames</i> =&gt; <i>result</i></a>
<blockquote>
<p>Given a list of, probably relative, pathnames returns a single
filename pathname containing the logical concatenation of them all.</p>
<p>The returned value&#039;s defaults are taken from the first element of
<code><i>pathnames</i></code> (host, version and device). The returned
values&#039;s name, type and version are taken from the last element
of <code><i>pathnames</i></code>. The intervening elements are used only for
their pathname-directory values.</p>
Examples:
<pre>
(merge-pathnames-as-file #P&quot;foo/&quot; #P&quot;bar.txt&quot;) == #P&quot;foo/bar.txt&quot;
(merge-pathnames-as-file #P&quot;foo/&quot; #P&quot;./bar.txt&quot;) == #P&quot;foo/./bar.txt&quot;
(merge-pathnames-as-file #P&quot;foo/&quot; #P&quot;/bar/README&quot;) == #P&quot;/bar/README&quot;
(merge-pathnames-as-file #P&quot;/foo/&quot; #P&quot;/bar/&quot; #P&#039;quux/file.txt) == #P&quot;/bar/quux/file.txt&quot;
</pre>
</blockquote>
<p><br>[Function]
<br><a class=none name="pathname-as-directory"><b>pathname-as-directory</b> <i> pathspec </i> =&gt; <i> pathname</i></a>
<blockquote><br>
Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>directory form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <em>true</em> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
</blockquote>
<p><br>[Function]
<br><a class=none name="pathname-as-file"><b>pathname-as-file</b> <i> pathspec </i> =&gt; <i> pathname</i></a>
<blockquote><br>
Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>file form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <code>NIL</code> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-directory-pathname'><b>pathname-directory-pathname</b> <i>pathname</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns a complete pathname representing the directory of
<code><i>pathname</i></code>. If <code><i>pathname</i></code> is
already a directory pathname
(<code>name</code> <code>nil</code>, <code>type</code>
<code>nil</code>) returns a pathname equal (as
per <a href="#pathname-equal">pathname-equal</a>) to it.</p>
</blockquote>
<p><br>[Function]<br><a class=none name='pathname-parent-directory'><b>pathname-parent-directory</b> <i>pathname</i> =&gt; <i>result</i></a>
<blockquote>
<p>Returns a pathname which would, by name at least,
contain <code><i>pathname</i></code> as one of its direct
children. Symlinks can make the parent/child relationship a like
opaque, but generally speaking the value returned by this function is
a directory name which contains <code><i>pathname</i></code>.</p>
<p>The root directory, #P&quot;/&quot;, is its own parent. The parent
directory of a filename is the parent of the filename&#039;s
dirname.</p>
</blockquote>
<h4><a class=none name="traversing">Traversing directories</a></h4>
<p><br>[Function]
<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&amp;key</tt> follow-symlinks</i> =&gt; <i> list</i></a>
<blockquote><br>
<p>
Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to
all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code>. The pathnames of sub-directories are returned in
<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
</p>
<p>
If <code><i>follow-symlinks</i></code> is true (which is the
default), then the returned list contains truenames (symlinks will
be resolved) which essentially means that it might also return files
from <b>outside</b> the directory. This works on all platforms.
</p>
<p>
When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory
contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.)
</p>
</blockquote>
<p><br>[Function]
<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&amp;key</tt> directories if-does-not-exist test follow-symlinks</i> =&gt; |</a>
<blockquote><br>
<p>
Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
designator</a> <code><i>fn</i></code> to all files within the directory named
by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname
designator</a> <code><i>dirname</i></code> and all of its sub-directories. <code><i>fn</i></code>
will only be applied to files for which the function <code><i>test</i></code>
returns a <em>true</em> value. (The default value for <code><i>test</i></code>
always returns <em>true</em>.) If <code><i>directories</i></code> is not <code>NIL</code>,
<code><i>fn</i></code> and <code><i>test</i></code> are applied to directories
as well. If <code><i>directories</i></code> is <code>:DEPTH-FIRST</code>, <code><i>fn</i></code>
will be applied to the directory's contents first. If <code><i>directories</i></code>
is <code>:BREADTH-FIRST</code> and <code><i>test</i></code> returns <code>NIL</code>, the
directory's content will be skipped. <code><i>if-does-not-exist</i></code> must
be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code>
(the default) means that an error will be signaled if the directory <code><i>dirname</i></code>
does not exist.
</p>
<p>
If <code><i>follow-symlinks</i></code> is true (which is
the default), then your callback will receive truenames. Otherwise
you should get the actual directory contents, which might include
symlinks. This might not be supported on all platforms. See
<a href="#list-directory"><code>LIST-DIRECTORY</code></a>.
</p>
</blockquote>
<h4><a class=none name="temporary-files">Temporary Files</a></h4>
<h5>Synopsis</h5>
<p>
Create a temporary file and return its name:
<pre>CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-output-to-temporary-file">with-output-to-temporary-file</a></code> (foo)
(print "hello" foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"</pre>
</p>
<p>
Create a temporary file, read and write it, have it be deleted
automatically:
<pre>CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :direction :io)
(print "hello" foo)
(file-position foo 0)
(read foo))
"hello"</pre>
</p>
<h5><a class="none" name="default-temporary-directory">Default temporary file directory</a></h5>
By default, temporary files are created in a system specific
directory that defaults based on operating system conventions. On
Unix and Unix-like systems, the directory <tt>/tmp/</tt> is used
by default. It can be overridden by setting the <tt>TMPDIR</tt>
environment variable. On Windows, the value of the environment
variable <tt>TEMP</tt> is used. If it is not set, temporary file
creation will fail.
<h5><a class="none" name="defining-temporary-directory">Defining the temporary file directory</a></h5>
<p>
The Lisp application can set the default directory in which
temporary files are created by the way of the
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host:
<pre>(setf (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "<code xmlns=""><a href="#temporary-files">temporary-files</a></code>") '(("*.*.*" "/var/tmp/")))</pre>
This would set the directory for temporary files to
<tt>/var/tmp/</tt>. For more information about logical
pathnames, please refer to <a href="http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/html/cltl/clm/node208.html#SECTION002715000000000000000">Common
Lisp the Language, 2nd Edition</a> and the <a href="http://clhs.lisp.se/Body/19_.htm">Common Lisp
HyperSpec</a>.
</p>
<p>
Physical path names have restrictions regarding the permitted
character in file names. If these restrictions conflict with
your desired naming scheme, you can pass a physical pathname as
TEMPLATE parameter to the temporary file generation function.
</p>
<p>
Here are a few examples:
<pre>CL-USER&gt; (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "temporary-files")
(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo)
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"</pre>
This used the temporary directory established in the TMPDIR
environment variable, by the way of the definition of the
temporary-files logical host definition.
<pre>CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "/tmp/file.with.dots.in.name.%.txt")
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"</pre>
Here, a physical pathname was used for the
<code xmlns=""><i>:template</i></code> keyword argument so that a
filename containing multiple dots could be generated.
<pre>CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "temporary-files:blah-%.txt")
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"</pre>
This used the temporary-files logical pathname host, but changed
the filename slightly.
<pre>CL-USER&gt; *default-pathname-defaults*
#P"/Users/hans/"
CL-USER&gt; (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "blah-%.txt")
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
#P"/Users/hans/blah-5OEJELG2.txt"</pre>
Here, a relative pathname was used in the template, which
caused the file to be generated in the directory established
by <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>.
</p>
<p>
Alternatively, the <code xmlns=""><a href="#*default-template*">*default-template*</a></code>
special variable can be set to define a custom default template
for generating names.
</p>
<h5 xmlns=""><a class="none" name="security">Security</a></h5>
The TEMPORARY-FILE library does not directly address security
issues. The application that uses it needs to take additional
measures if it is important that files created by one process
cannot be accessed by other, unrelated processes. This can be
done by using the system dependent security mechanisms like
default file permissions or access control lists.
<h5>Dictionary</h5>
<p xmlns="">[Function]<br><a class="none" name="open-temporary"><b>open-temporary</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc"><tt>&amp;rest</tt> open-arguments <tt>&amp;key</tt> template generate-random-string max-tries <tt>&amp;allow-other-keys</tt></clix:lambda-list></i>
=&gt;
<i>stream</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
<p xmlns="http://www.w3.org/1999/xhtml">
Create a file with a randomly generated name and return the
opened stream. The resulting pathname is generated from
<code xmlns=""><i>template</i></code>, which is a string
representing a pathname template. A percent sign (%) in
that string is replaced by a randomly generated string to
make the filename unique. The default for
<code xmlns=""><i>template</i></code> places temporary files in the
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host,
which is automatically set up in a system specific manner.
The file name generated from <code xmlns=""><i>template</i></code>
is merged with <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>,
so random pathnames relative to that directory can be
generated by not specifying a directory in
<code xmlns=""><i>template</i></code>.
</p>
<p xmlns="http://www.w3.org/1999/xhtml">
<code xmlns=""><i>generate-random-string</i></code> can be passed to
override the default function that generates the random name
component. It should return a random string consisting of
characters that are permitted in a pathname (logical or
physical, depending on <code xmlns=""><i>template</i></code>).
</p>
<p xmlns="http://www.w3.org/1999/xhtml">
The name of the temporary file can be accessed calling the
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a>
function on <code xmlns=""><i>stream</i></code>. For convenience,
the temporary file is opened on the physical pathname,
i.e. if the <code xmlns=""><i>template</i></code> designate a
logical pathname the translation to a physical pathname is
performed before opening the stream.
</p>
<p xmlns="http://www.w3.org/1999/xhtml">
In order to create a unique file name,
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> may loop internally up
to <code xmlns=""><i>max-tries</i></code> times before giving up and
signalling a
<code xmlns=""><a href="#cannot-create-temporary-file">cannot-create-temporary-file</a></code> condition.
</p>
<p xmlns="http://www.w3.org/1999/xhtml">
Any unrecognized keyword arguments are passed to the call to
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm">open</a>.
</p>
</clix:description></blockquote></p>
<p xmlns="">[Macro]<br><a class="none" name="with-output-to-temporary-file"><b>with-output-to-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&amp;rest</tt> args) <tt>&amp;body</tt> body</clix:lambda-list></i>
=&gt;
<i>pathname</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
Create a temporary file using
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
with <code xmlns=""><i>stream</i></code> bound to the temporary file
stream. Returns the pathname of the file that has been
created. See <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for
permitted options.
</clix:description></blockquote></p>
<p xmlns="">[Macro]<br><a class="none" name="with-open-temporary-file"><b>with-open-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&amp;rest</tt> args <tt>&amp;key</tt> keep <tt>&amp;allow-other-keys</tt>) <tt>&amp;body</tt> body</clix:lambda-list></i>
=&gt;
<i>values</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
Create a temporary file using
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
with <code xmlns=""><i>stream</i></code> bound to the temporary file
stream. Returns the values returned by
<code xmlns=""><i>body</i></code>. By default, the file is deleted
when <code xmlns=""><i>body</i></code> is exited. If a true value is
passed in <code xmlns=""><i>keep</i></code>, the file is not deleted
when the body is exited. See
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for more permitted
options.
</clix:description></blockquote></p>
<p xmlns="">
[Special variable]<br><a class="none" name="*default-template*"><b>*default-template*</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
This variable can be set to a string representing the desired
default template for temporary file name generation. See
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for a description of the
template string format.
</clix:description></blockquote></p>
<p xmlns="">
[Condition type]<br><a class="none" name="cannot-create-temporary-file"><b>cannot-create-temporary-file</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
Signalled when an attempt to create unique temporary file name
failed after the established number of retries.
</clix:description></blockquote></p>
<p xmlns="">
[Condition type]<br><a class="none" name="invalid-temporary-pathname-template"><b>invalid-temporary-pathname-template</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
Signalled when the <code xmlns=""><i>template</i></code> argument to
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> does not contain a valid
template string. The template string must contain a percent
sign, which is replaced by the generated random string to
yield the filename.
</clix:description></blockquote></p>
<p xmlns="">
[Condition type]<br><a class="none" name="missing-temp-environment-variable"><b>missing-temp-environment-variable</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
(Windows only) Signalled when the TEMP environment variable is
not set.
</clix:description></blockquote></p>
<p xmlns="">
[Logical Pathname Host]<br><a class="none" name="lp-host-temporary-files"><b>temporary-files</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
This logical pathname host defines where temporary files are
stored by default. It is initialized in a suitable system
specific fashion: On Unix and Unix-like systems, the directory
specified in the TMPDIR environment variable is used. If that
variable is not set, /tmp is used as the default. On Windows,
the directory specified in the TEMP environment variable is
used. If it is not set, a
<code xmlns=""><a href="#missing-temp-environment-variable">missing-temp-environment-variable</a></code> error
is signalled.
</clix:description></blockquote></p>
<h4><a class=none name="modifying">Modifying the file system</a></h4>
<p><br>[Function]
<br><a class=none name="copy-file"><b>copy-file</b> <i> from to <tt>&amp;key</tt> overwrite</i> =&gt; |</a>
<blockquote><br>
Copies the file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>from</i></code> to the
file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>to</i></code>. If <code><i>overwrite</i></code> is <em>true</em> (the default is <code>NIL</code>)
overwrites the file designated by <code><i>to</i></code> if it exists.
</blockquote>
<p><br>[Function]
<br><a class=none name="copy-stream"><b>copy-stream</b> <i> from to <tt>&amp;optional</tt> checkp</i> =&gt; |</a>
<blockquote><br> Copies into <code><i>to</i></code> (a stream)
from <code><i>from</i></code> (also a stream) until the end
of <code><i>from</i></code> is reached. The streams should have the
same <a
href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stm_el.htm">element
type</a> unless they are bivalent. If <code><i>checkp</i></code> is
true (which is the default), the function will signal an error if the
element types aren't the same.
</blockquote>
<p><br>[Function]
<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname <tt>&amp;key</tt> if-does-not-exist</i> =&gt; |</a>
<blockquote><br>
<p>
Recursively deletes all files and directories within the directory
designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code> including
<code><i>dirname</i></code> itself. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code>
where <code>:ERROR</code> (the default) means that an error will be signaled if the directory
<code><i>dirname</i></code> does not exist.
</p>
<p>
<b>Warning:</b> this function <em>might</em> remove files from outside the
directory, if the directory that you are deleting contains links to
external files. This is currently fixed for SBCL and CCL.
</p>
</blockquote>
<h4>The <code>PATH</code> package</h4>
<p><br>[Package]
<br><a class=none name="package-path">(defpackage <b>path</b>)</a>
<blockquote>
Provides a set of short names for commonly used pathname manipulation
functions (these are all functions from the <code>cl-fad</code>
package which are being exported under different names):
<dl>
<dt><code>dirname</code></dt> <dd><a href="#pathname-as-directory">pathname-as-directory</a></dd>
<dt><code>basename</code></dt> <dd><code>cl:file-namestring</code></dd>
<dt><code>-e</code></dt> <dd><a href="#file-exists-p">file-exists-p</a></dd>
<dt><code>-d</code></dt> <dd><a href="#directory-exists-p">directory-exists-p</a></dd>
<dt><code>catfile</code></dt> <dd><a href="#merge-pathnames-as-file">merge-pathnames-as-file</a></dd>
<dt><code>catdir</code></dt> <dd><a href="#merge-pathnames-as-directory">merge-pathnames-as-directory</a></dd>
<dt><code>rm-r</code></dt> <dd><a href="#delete-directory-and-files">delete-directory-and-files</a></dd>
<dt><code>=</code></dt> <dd><a href="#pathname-equal">pathname-equal</a></dd>
<dt><code>absolute-p</code></dt> <dd><a href="#pathname-absolute-p">pathname-absolute-p</a></dd>
<dt><code>relative-p</code></dt> <dd><a href="#pathname-relative-p">pathname-relative-p</a></dd>
<dt><code>root-p</code></dt> <dd><a href="#pathname-root-p">pathname-root-p</a></dd>
</dl>
</blockquote>
<br>&nbsp;<br><h3><a class=none name="ack">Acknowledgements</a></h3>
The original code for this library was written by Peter Seibel for his
book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common
Lisp</em></a>. I added some stuff and made sure it worked properly on
Windows, specifically with CCL. Thanks to James Bielman, Maciek
Pasternacki, Jack D. Unrue, Gary King, and Douglas Crosher who sent
patches for OpenMCL, ECL, ABCL, MCL, and Scieneer&nbsp;CL.
<p>
$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $
<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
</body>
</html>

570
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/fad.lisp Normal file
View file

@ -0,0 +1,570 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.35 2009/09/30 14:23:10 edi Exp $
;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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 AUTHORS '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.
(in-package :cl-fad)
(defun component-present-p (value)
"Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
is neither NIL nor the keyword :UNSPECIFIC."
(and value (not (eql value :unspecific))))
(defun directory-pathname-p (pathspec)
"Returns NIL if PATHSPEC \(a pathname designator) does not designate
a directory, PATHSPEC otherwise. It is irrelevant whether file or
directory designated by PATHSPEC does actually exist."
(and
(not (component-present-p (pathname-name pathspec)))
(not (component-present-p (pathname-type pathspec)))
pathspec))
(defun pathname-as-directory (pathspec)
"Converts the non-wild pathname designator PATHSPEC to directory
form."
(let ((pathname (pathname pathspec)))
(when (wild-pathname-p pathname)
(error "Can't reliably convert wild pathnames."))
(cond ((not (directory-pathname-p pathspec))
(make-pathname :directory (append (or (pathname-directory pathname)
(list :relative))
(list (file-namestring pathname)))
:name nil
:type nil
:defaults pathname))
(t pathname))))
(defun directory-wildcard (dirname)
"Returns a wild pathname designator that designates all files within
the directory named by the non-wild pathname designator DIRNAME."
(when (wild-pathname-p dirname)
(error "Can only make wildcard directories from non-wildcard directories."))
(make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
:type #-(or :clisp :cormanlisp) :wild
#+:clisp nil
#+:cormanlisp "*"
:defaults (pathname-as-directory dirname)))
#+:clisp
(defun clisp-subdirectories-wildcard (wildcard)
"Creates a wild pathname specifically for CLISP such that
sub-directories are returned by DIRECTORY."
(make-pathname :directory (append (pathname-directory wildcard)
(list :wild))
:name nil
:type nil
:defaults wildcard))
(defun list-directory (dirname &key (follow-symlinks t))
"Returns a fresh list of pathnames corresponding to all files within
the directory named by the non-wild pathname designator DIRNAME.
The pathnames of sub-directories are returned in directory form -
see PATHNAME-AS-DIRECTORY.
If FOLLOW-SYMLINKS is true, then the returned list contains
truenames (symlinks will be resolved) which essentially means that it
might also return files from *outside* the directory. This works on
all platforms.
When FOLLOW-SYMLINKS is NIL, it should return the actual directory
contents, which might include symlinks. Currently this works on SBCL
and CCL."
(declare (ignorable follow-symlinks))
(when (wild-pathname-p dirname)
(error "Can only list concrete directory names."))
#+(or :ecl :clasp)
(let ((dir (pathname-as-directory dirname)))
(concatenate 'list
(directory (merge-pathnames (pathname "*/") dir))
(directory (merge-pathnames (pathname "*.*") dir))))
#-(or :ecl :clasp)
(let ((wildcard (directory-wildcard dirname)))
#+:abcl (system::list-directory dirname)
#+:sbcl (directory wildcard :resolve-symlinks follow-symlinks)
#+(or :cmu :scl :lispworks) (directory wildcard)
#+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks)
#+:allegro (directory wildcard :directories-are-files nil)
#+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
(directory (clisp-subdirectories-wildcard wildcard)))
#+:cormanlisp (nconc (directory wildcard)
(cl::directory-subdirs dirname)))
#-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool :clasp)
(error "LIST-DIRECTORY not implemented"))
(defun pathname-as-file (pathspec)
"Converts the non-wild pathname designator PATHSPEC to file form."
(let ((pathname (pathname pathspec)))
(when (wild-pathname-p pathname)
(error "Can't reliably convert wild pathnames."))
(cond ((directory-pathname-p pathspec)
(let* ((directory (pathname-directory pathname))
(name-and-type (pathname (first (last directory)))))
(make-pathname :directory (butlast directory)
:name (pathname-name name-and-type)
:type (pathname-type name-and-type)
:defaults pathname)))
(t pathname))))
(defun file-exists-p (pathspec)
"Checks whether the file named by the pathname designator PATHSPEC
exists and returns its truename if this is the case, NIL otherwise.
The truename is returned in `canonical' form, i.e. the truename of a
directory is returned as if by PATHNAME-AS-DIRECTORY."
#+(or :sbcl :lispworks :openmcl :ecl :digitool clasp) (probe-file pathspec)
#+:allegro (or (excl:probe-directory (pathname-as-directory pathspec))
(probe-file pathspec))
#+(or :cmu :scl :abcl) (or (probe-file (pathname-as-directory pathspec))
(probe-file pathspec))
#+:cormanlisp (or (and (ccl:directory-p pathspec)
(pathname-as-directory pathspec))
(probe-file pathspec))
#+:clisp (or (ignore-errors
(let ((directory-form (pathname-as-directory pathspec)))
(when (ext:probe-directory directory-form)
(truename directory-form))))
(ignore-errors
(probe-file (pathname-as-file pathspec))))
#-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool :clasp)
(error "FILE-EXISTS-P not implemented"))
(defun directory-exists-p (pathspec)
"Checks whether the file named by the pathname designator PATHSPEC
exists and if it is a directory. Returns its truename if this is the
case, NIL otherwise. The truename is returned in directory form as if
by PATHNAME-AS-DIRECTORY."
#+:allegro
(and (excl:probe-directory pathspec)
(pathname-as-directory (truename pathspec)))
#+:lispworks
(and (lw:file-directory-p pathspec)
(pathname-as-directory (truename pathspec)))
#-(or :allegro :lispworks)
(let ((result (file-exists-p pathspec)))
(and result
(directory-pathname-p result)
result)))
(defun walk-directory (dirname fn &key directories
(if-does-not-exist :error)
(test (constantly t))
(follow-symlinks t))
"Recursively applies the function FN to all files within the
directory named by the non-wild pathname designator DIRNAME and all of
its sub-directories. FN will only be applied to files for which the
function TEST returns a true value. If DIRECTORIES is not NIL, FN and
TEST are applied to directories as well. If DIRECTORIES
is :DEPTH-FIRST, FN will be applied to the directory's contents first.
If DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the directory's
content will be skipped. IF-DOES-NOT-EXIST must be one of :ERROR
or :IGNORE where :ERROR means that an error will be signaled if the
directory DIRNAME does not exist. If FOLLOW-SYMLINKS is T, then your
callback will receive truenames. Otherwise you should get the actual
directory contents, which might include symlinks. This might not be
supported on all platforms. See LIST-DIRECTORY."
(labels ((walk (name)
(cond
((directory-pathname-p name)
;; the code is written in a slightly awkward way for
;; backward compatibility
(cond ((not directories)
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
(walk file)))
((eql directories :breadth-first)
(when (funcall test name)
(funcall fn name)
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
(walk file))))
;; :DEPTH-FIRST is implicit
(t (dolist (file (list-directory name :follow-symlinks follow-symlinks))
(walk file))
(when (funcall test name)
(funcall fn name)))))
((funcall test name)
(funcall fn name)))))
(let ((pathname-as-directory (pathname-as-directory dirname)))
(case if-does-not-exist
((:error)
(cond ((not (file-exists-p pathname-as-directory))
(error "File ~S does not exist."
pathname-as-directory))
(t (walk pathname-as-directory))))
((:ignore)
(when (file-exists-p pathname-as-directory)
(walk pathname-as-directory)))
(otherwise
(error "IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE."))))
(values)))
(defvar *stream-buffer-size* 8192)
(defun copy-stream (from to &optional (checkp t))
"Copies into TO \(a stream) from FROM \(also a stream) until the end
of FROM is reached, in blocks of *stream-buffer-size*. The streams
should have the same element type. If CHECKP is true, the streams are
checked for compatibility of their types."
(when checkp
(unless (subtypep (stream-element-type to) (stream-element-type from))
(error "Incompatible streams ~A and ~A." from to)))
(let ((buf (make-array *stream-buffer-size*
:element-type (stream-element-type from))))
(loop
(let ((pos #-:clisp (read-sequence buf from)
#+:clisp (ext:read-byte-sequence buf from :no-hang nil)))
(when (zerop pos) (return))
(write-sequence buf to :end pos))))
(values))
(defun copy-file (from to &key overwrite)
"Copies the file designated by the non-wild pathname designator FROM
to the file designated by the non-wild pathname designator TO. If
OVERWRITE is true overwrites the file designated by TO if it exists."
#+:allegro (excl.osi:copy-file from to :overwrite overwrite)
#-:allegro
(let ((element-type #-:cormanlisp '(unsigned-byte 8)
#+:cormanlisp 'unsigned-byte))
(with-open-file (in from :element-type element-type)
(with-open-file (out to :element-type element-type
:direction :output
:if-exists (if overwrite
:supersede
#-:cormanlisp :error
#+:cormanlisp nil))
#+:cormanlisp
(unless out
(error (make-condition 'file-error
:pathname to
:format-control "File already exists.")))
(copy-stream in out))))
(values))
(defun delete-directory-and-files (dirname &key (if-does-not-exist :error))
"Recursively deletes all files and directories within the directory
designated by the non-wild pathname designator DIRNAME including
DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
where :ERROR means that an error will be signaled if the directory
DIRNAME does not exist.
NOTE: this function is dangerous if the directory that you are
removing contains symlinks to files outside of it - the target files
might be removed instead! This is currently fixed for SBCL and CCL."
#+:allegro (excl.osi:delete-directory-and-files dirname
:if-does-not-exist if-does-not-exist)
#+:sbcl
(if (directory-exists-p dirname)
(sb-ext:delete-directory dirname :recursive t)
(ecase if-does-not-exist
(:error (error "~S is not a directory" dirname))
(:ignore nil)))
#+:ccl-has-delete-directory
(if (directory-exists-p dirname)
(ccl:delete-directory dirname)
(ecase if-does-not-exist
(:error (error "~S is not a directory" dirname))
(:ignore nil)))
#-(or :allegro :sbcl :ccl-has-delete-directory)
(walk-directory dirname
(lambda (file)
(cond ((directory-pathname-p file)
#+:lispworks (lw:delete-directory file)
#+:cmu (multiple-value-bind (ok err-number)
(unix:unix-rmdir (namestring (truename file)))
(unless ok
(error "Error number ~A when trying to delete ~A"
err-number file)))
#+:scl (multiple-value-bind (ok errno)
(unix:unix-rmdir (ext:unix-namestring (truename file)))
(unless ok
(error "~@<Error deleting ~S: ~A~@:>"
file (unix:get-unix-error-msg errno))))
#+:clisp (ext:delete-directory file)
#+:openmcl (cl-fad-ccl:delete-directory file)
#+:cormanlisp (win32:delete-directory file)
#+:ecl (si:rmdir file)
#+:clasp (core:rmdir file)
#+(or :abcl :digitool) (delete-file file))
(t (delete-file file))))
:follow-symlinks nil
:directories t
:if-does-not-exist if-does-not-exist)
(values))
(defun pathname-directory-pathname (pathname)
"Returns a complete pathname representing the directory of
PATHNAME. If PATHNAME is already a directory pathname (name NIL, type
NIL) returns a pathname equal (as per pathname=) to it."
(make-pathname :defaults pathname
:name nil :type nil))
(defun pathname-parent-directory (pathname)
"Returns a pathname which would, by name at least, contain PATHNAME
as one of its direct children. Symlinks can make the parent/child
relationship a like opaque, but generally speaking the value returned
by this function is a directory name which contains PATHNAME.
The root directory, #P\"/\", is its own parent. The parent directory
of a filename is the parent of the filename's dirname."
(canonical-pathname
(make-pathname :defaults pathname
:directory (if (pathname-root-p pathname)
(list :absolute)
(append (or (pathname-directory pathname)
(list :relative))
(list :back))))))
(defun canonical-pathname (pathname)
"Remove redundant information from PATHNAME.
This simply walks down PATHNAME's pathname-directory and drops \".\"
directories, removes :back and its preceding element.
NB: This function does not access the filesystem, it only looks at the
values in the pathname and works on their known (or assumed)
meanings.
NB: Since this function does not access the filesystem it will only
remove :BACK elements from the path (not :UP elements). Since some
lisps, ccl/sbcl/clisp convert \"..\" in pathnames to :UP, and
not :BACK, the actual utility of the function is limited."
(let ((pathname (pathname pathname))) ;; just make sure to get a pathname object
(loop
with full-dir = (or (pathname-directory pathname)
(list :relative))
with canon-dir = (if (member (first full-dir) '(:relative :absolute))
(list (pop full-dir))
(list :relative))
while full-dir
do (cond
((string= "." (first full-dir))
(pop full-dir))
((eql :back (second full-dir))
(pop full-dir)
(pop full-dir))
(t (push (pop full-dir) canon-dir)))
finally (return (make-pathname :defaults pathname :directory (nreverse canon-dir))))))
(defun merge-pathnames-as-directory (&rest pathnames)
"Given a list of (probably relative) pathnames, this returns a single
directory pathname containing the logical concatenation of them all.
The returned value is the current directory if one were to cd into
each of PATHNAMES in order. For this reason an absolute pathname will,
effectively, cancel the affect of any previous relative pathnames.
The returned value's defaults are taken from the first element of
PATHNAMES (host, version and device).
NB: Since this function only looks at directory names the name and
type of the elements of PATHNAMES are ignored. Make sure to properly
use either trailing #\\/s, or pathname-as-directory, to get the
expected results.
Examples:
(merge-pathnames-as-directory #P\"foo/\" #P\"bar/\") == #P\"foo/bar/\"
(merge-pathnames-as-directory #P\"foo/\" #P\"./bar/\") == #P\"foo/./bar/\"
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\") == #P\"/bar/\"
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/\"
"
(if pathnames
(let* ((pathnames (mapcar #'pathname pathnames))
(defaults (first pathnames))
(dir (pathname-directory defaults)))
(loop for pathname in (rest pathnames)
for directory = (pathname-directory pathname)
do (ecase (first directory)
;; this is equivalent to (:relative) == ".", so,
;; for this function, just do nothing.
((nil))
(:absolute
(setf dir directory))
(:relative
(setf dir (append dir (rest directory))))))
(make-pathname :defaults defaults :directory dir :name nil :type nil))
(make-pathname)))
(defun merge-pathnames-as-file (&rest pathnames)
"Given a list of, probably relative, pathnames returns a single
filename pathname containing the logical concatenation of them all.
The returned value's defaults are taken from the first element of
PATHNAMES (host, version and device). The returned values's name, type
and version are taken from the last element of PATHNAMES. The
intervening elements are used only for their pathname-directory
values.
Examples:
(merge-pathnames-as-file #P\"foo/\" #P\"bar.txt\") == #P\"foo/bar.txt\"
(merge-pathnames-as-file #P\"foo/\" #P\"./bar.txt\") == #P\"foo/./bar.txt\"
(merge-pathnames-as-file #P\"foo/\" #P\"/bar/README\") == #P\"/bar/README\"
(merge-pathnames-as-file #P\"/foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/file.txt\"
"
(cond ((null pathnames)
(make-pathname))
((null (cdr pathnames))
(pathname-as-file (first pathnames)))
(t
(let ((file-name-part (first (last pathnames))))
(make-pathname :defaults (apply #'merge-pathnames-as-directory pathnames)
:name (pathname-name file-name-part)
:type (pathname-type file-name-part)
:version (pathname-version file-name-part))))))
(defmacro with-component-testers ((a b key) &body body)
(let ((k (gensym)))
`(let* ((,k ,key)
(,a (funcall ,k ,a))
(,b (funcall ,k ,b)))
(labels ((components-are (test)
(and (funcall test ,a) (funcall test ,b)))
(components-are-member (values)
(and (member ,a values :test #'eql)
(member ,b values :test #'eql)
(eql ,a ,b)))
(components-are-string= ()
(and (stringp ,a) (stringp ,b) (string= ,a ,b)))
(components-are-every (test)
(and (consp ,a)
(consp ,b)
(every test ,a ,b))))
(declare (ignorable #'components-are #'components-are-member
#'components-are-string= #'components-are-every))
(if (or ,@body)
(values t ,a ,b)
nil)))))
(defun pathname-host-equal (a b)
(with-component-testers (a b #'pathname-host)
(eq a b)
(components-are-member '(nil :unspecific))
(components-are-string=)
(components-are-every #'string=)))
(defun pathname-device-equal (a b)
(with-component-testers (a b #'pathname-device)
(components-are-member '(nil :unspecific))
(components-are-string=)))
(defun pathname-directory-equal (a b)
(with-component-testers (a b #'pathname-directory)
(and (null a) (null b))
(and (= (length a) (length b))
(every (lambda (a b)
(or (and (stringp a) (stringp b) (string= a b))
(and (null a) (null b))
(and (keywordp a) (keywordp b) (eql a b))))
a b))))
(defun pathname-name-equal (a b)
(with-component-testers (a b #'pathname-name)
(components-are-member '(nil :wild :unspecific))
(components-are-string=)))
(defun pathname-type-equal (a b)
(with-component-testers (a b #'pathname-type)
(components-are-member '(nil :wild :unspecific))
(components-are-string=)))
(defun pathname-version-equal (a b)
(with-component-testers (a b #'pathname-version)
(and (null a) (null b))
(components-are-member '(:wild :newest :unspecific))
(and (integerp a) (integerp b) (= a b))))
(defun pathname-equal (a b)
"Returns T if A and B represent the same pathname. This function
does not access the filesystem, it only looks at the components of the
two pathnames to test if they are the same (though by
passing both A and B to probe-file one can make this function test for file 'sameness'.
Equality is defined as:
- strings that are string equal
- symbol (including nil) or keywords which are eql
- lists of the same length with equal (as per these rules) elements.
if any of these tree conditions is false for any of the components in
A and B then A and B are different, otherwise they are the same.
NB: This function does not convert name strings to pathnames. So
\"foo.txt\" and #P\"foo.txt\" are different pathnames."
(if (and a b)
(if (and (pathname-host-equal a b)
(pathname-device-equal a b)
(pathname-directory-equal a b)
(pathname-name-equal a b)
(pathname-type-equal a b)
(pathname-version-equal a b))
(values t a b)
(values nil))
(values nil)))
(defun pathname-absolute-p (a)
"Returns true if A is an absolute pathname.
This simply tests if A's directory list starts with :ABSOLUTE"
(eql :absolute (first (pathname-directory (pathname a)))))
(defun pathname-relative-p (a)
"Returns true if A is a relative pathname.
This simply tests if A's directory starts with :RELATIVE."
(let ((dir (pathname-directory (pathname a))))
(or (null dir) (eql :relative (first dir)))))
(defun pathname-root-p (a)
(let ((dir (pathname-directory (pathname a))))
(and (eql :absolute (first dir))
(= 1 (length dir)))))
(pushnew :cl-fad *features*)
;; stuff for Nikodemus Siivola's HYPERDOC
;; see <http://common-lisp.net/project/hyperdoc/>
;; and <http://www.cliki.net/hyperdoc>
;; also used by LW-ADD-ONS
#-:abcl
(defvar *hyperdoc-base-uri* "http://weitz.de/cl-fad/")
#-:abcl
(let ((exported-symbols-alist
(loop for symbol being the external-symbols of :cl-fad
collect (cons symbol
(concatenate 'string
"#"
(string-downcase symbol))))))
(defun hyperdoc-lookup (symbol type)
(declare (ignore type))
(cdr (assoc symbol
exported-symbols-alist
:test #'eq))))

157
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/fad.test.lisp Normal file
View file

@ -0,0 +1,157 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD-TEST; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/test.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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.
(in-package #:cl-fad-test)
(defparameter *tmp-dir*
#+(or :win32 :mswindows :windows) "c:\\tmp\\"
#-(or :win32 :mswindows :windows) "/tmp/")
(defvar *test-counter* 0)
(defmacro assert* (form)
`(progn
(format t "Trying to assert ~A~%" ',form)
(assert ,form)
(format t "Test ~A passed.~%" (incf *test-counter*))))
(defun test ()
(setq *test-counter* 0)
(assert* (path:= (path:catdir) #P""))
(assert* (path:= (path:catdir #P"/") #P"/"))
(assert* (path:= (path:catdir #P"a/" #P"b/") #P"a/b/"))
(assert* (path:= (path:catdir #P"/a/" #P"/b/" #P"c/" #P"./d/" #P"e" #P"f/") #P"/b/c/./d/f/"))
(assert* (path:= (path:catfile) #P""))
(assert* (path:= (path:catfile #P"R.txt") #P"R.txt"))
(assert* (path:= (path:catfile #P"a/" #P"/b/" #P"R.txt") #P"/b/R.txt"))
(let ((fad-dir (merge-pathnames (pathname-as-directory "fad-test")
*tmp-dir*)))
(delete-directory-and-files fad-dir :if-does-not-exist :ignore)
(assert* (directory-pathname-p fad-dir))
(assert* (directory-pathname-p (pathname *tmp-dir*)))
(let ((foo-file (merge-pathnames "foo.lisp"
fad-dir)))
(assert* (not (directory-pathname-p foo-file)))
(assert* (not (file-exists-p foo-file)))
(assert* (not (file-exists-p fad-dir)))
(with-open-file (out (ensure-directories-exist foo-file)
:direction :output
:if-does-not-exist :create)
(write-string "NIL" out))
(assert* (file-exists-p foo-file))
(assert* (not (directory-exists-p foo-file)))
(assert* (file-exists-p fad-dir))
(assert* (directory-exists-p fad-dir))
(assert* (equal fad-dir
(pathname-as-directory fad-dir)))
(assert* (equal foo-file
(pathname-as-file foo-file)))
(assert* (not (equal fad-dir
(pathname-as-file fad-dir))))
(assert* (not (equal foo-file
(pathname-as-directory foo-file))))
(dolist (name '("bar" "baz"))
(let ((dir (merge-pathnames (pathname-as-directory name)
fad-dir)))
(dolist (name '("foo.text" "bar.lisp"))
(let ((file (merge-pathnames name dir)))
(with-open-file (out (ensure-directories-exist file)
:direction :output
:if-does-not-exist :create)
(write-string "NIL" out))))))
;; /tmp/fad-test/foo.lisp
;; /tmp/fad-test/bar/bar.lisp
;; /tmp/fad-test/bar/foo.text
;; /tmp/fad-test/baz/bar.lisp
;; /tmp/fad-test/baz/foo.text
;; files : 5
;; dirs : 3
(let ((file-counter 0)
(file-and-dir-counter 0)
(bar-counter 0))
(walk-directory fad-dir
(lambda (file)
(declare (ignore file))
(incf file-counter)))
;; file-counter => 5
(walk-directory fad-dir
(lambda (file)
(declare (ignore file))
(incf file-and-dir-counter))
:directories t)
;; file-and-dir-counter => 5 + 3
(walk-directory fad-dir
(lambda (file)
(declare (ignore file))
(incf bar-counter))
:test (lambda (file)
(string= (pathname-name file)
"bar"))
:directories t)
;; do not traverse the baz directory
(walk-directory fad-dir
(lambda (file)
(declare (ignore file))
(incf file-and-dir-counter))
:test (lambda (file)
(not (and (directory-pathname-p file)
(string= (first (last (pathname-directory file)))
"baz"))))
:directories :breadth-first)
;; file-and-dir-counter => 5 + 3 + 2 dirs + 3 files
(assert* (= 5 file-counter))
(assert* (= 13 file-and-dir-counter))
(assert* (= 2 bar-counter)))
(let ((bar-file (merge-pathnames "bar.lisp" fad-dir)))
(copy-file foo-file bar-file)
(assert* (file-exists-p bar-file))
(with-open-file (foo-stream foo-file :element-type '(unsigned-byte 8))
(with-open-file (bar-stream bar-file :element-type '(unsigned-byte 8))
(assert* (= (file-length foo-stream)
(file-length bar-stream)))
(loop for foo-byte = (read-byte foo-stream nil nil)
for bar-byte = (read-byte bar-stream nil nil)
while (and foo-byte bar-byte)
do (assert* (eql foo-byte bar-byte))))))
(let ((baz-dir (merge-pathnames (pathname-as-directory "baz")
fad-dir))
(list (mapcar #'namestring (list-directory fad-dir))))
(assert* (find (namestring (truename foo-file)) list :test #'string=))
(assert* (find (namestring (truename baz-dir)) list :test #'string=))
(assert* (not (find (namestring (pathname-as-file baz-dir))
list
:test #'string=)))))
(delete-directory-and-files fad-dir :if-does-not-exist :error)
(assert* (not (file-exists-p fad-dir)))
(assert* (not (directory-exists-p fad-dir))))
(format t "All tests passed.~%"))

62
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/load.lisp Normal file
View file

@ -0,0 +1,62 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/load.lisp,v 1.9 2009/09/30 14:23:10 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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.
(in-package :cl-user)
(defparameter *cl-fad-base-directory*
(make-pathname :name nil :type nil :version nil
:defaults (parse-namestring *load-truename*)))
#+:allegro (require :osi)
#+:sbcl (require :sb-executable)
#+:sbcl (require :sb-posix)
(let ((cl-fad-base-directory
(make-pathname :name nil :type nil :version nil
:defaults (parse-namestring *load-truename*))))
(let (must-compile)
#+:cormanlisp (declare (ignore must-compile))
(dolist (file '("packages"
#+:cormanlisp "corman"
#+:openmcl "openmcl"
"fad"))
(let ((pathname (make-pathname :name file :type "lisp" :version nil
:defaults cl-fad-base-directory)))
;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
;; will yield compiled functions anyway
#-:cormanlisp
(let ((compiled-pathname (compile-file-pathname pathname)))
(unless (and (not must-compile)
(probe-file compiled-pathname)
(< (file-write-date pathname)
(file-write-date compiled-pathname)))
(setq must-compile t)
(compile-file pathname))
(setq pathname compiled-pathname))
(load pathname)))))

72
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/openmcl.lisp Normal file
View file

@ -0,0 +1,72 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CCL; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/openmcl.lisp,v 1.6 2009/09/30 14:23:10 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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 AUTHORS '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.
(in-package :cl-fad)
(eval-when (:compile-toplevel :load-toplevel :execute)
(flet ((ccl-function-feature (symbol-name feature)
(let ((symbol (find-symbol symbol-name :ccl)))
(when (and symbol (fboundp symbol))
(pushnew feature *features*)))))
(ccl-function-feature "%RMDIR" :ccl-has-%rmdir)
(ccl-function-feature "DELETE-DIRECTORY" :ccl-has-delete-directory)))
(defpackage :cl-fad-ccl
(:use :cl)
(:export delete-directory)
(:import-from :ccl
:%realpath
:signal-file-error
:native-translated-namestring
:with-cstrs)
#+ccl-has-%rmdir
(:import-from :ccl :%rmdir)
#+ccl-has-delete-directory
(:import-from :ccl :delete-directory))
(in-package :cl-fad-ccl)
#-ccl-has-%rmdir
(defun %rmdir (name)
(with-cstrs ((n name))
(#_rmdir n)))
;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that
;;; are acceptably similar to this "legacy" definition.
;;;
;;; Except this legacy definition is not recursive, hence this function is
;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
#-ccl-has-delete-directory
(defun delete-directory (path)
(let* ((namestring (native-translated-namestring path)))
(when (%realpath namestring)
(let* ((err (%rmdir namestring)))
(or (eql 0 err) (signal-file-error err path))))))

87
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/packages.lisp Normal file
View file

@ -0,0 +1,87 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-fad/packages.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. 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.
(in-package #:cl-user)
(defpackage :cl-fad
(:nicknames :fad)
(:use :cl)
#+:allegro
(:shadow :copy-file
:delete-directory-and-files)
#+:abcl
(:shadow :list-directory)
(:export :copy-file
:copy-stream
:delete-directory-and-files
:directory-exists-p
:directory-pathname-p
:file-exists-p
:list-directory
:pathname-as-directory
:pathname-as-file
:pathname-directory-pathname
:pathname-equal
:pathname-parent-directory
:pathname-absolute-p
:pathname-relative-p
:pathname-root-p
:canonical-pathname
:merge-pathnames-as-directory
:merge-pathnames-as-file
:walk-directory
:open-temporary
:with-output-to-temporary-file
:with-open-temporary-file
:*default-template*
:invalid-temporary-pathname-template
:cannot-create-temporary-file
#+win32 #:missing-temp-environment-variable))
(defpackage :path
(:use)
(:documentation "Rexporting certain functions from the cl-fad package with shorter names.
This package provides no functionality, it serves only to make file
system intensive code easier to read (for unix people at least).")
(:export #:dirname
#:basename
#:-e
#:-d
#:catfile
#:catdir
#:rm-r
#:=
#:absolute-p
#:relative-p
#:root-p))

5
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/packages.test.lisp Normal file
View file

@ -0,0 +1,5 @@
(in-package :common-lisp-user)
(defpackage :cl-fad-test
(:use :cl :cl-fad :unit-test)
(:export :test))

32
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/path.lisp Normal file
View file

@ -0,0 +1,32 @@
(in-package :cl-fad)
(defmacro defalias (name args realname)
`(progn
(defun ,name ,args
,(if (eql '&rest (first args))
`(apply #',realname ,(second args))
`(,realname ,@args)))
(define-compiler-macro ,name (&rest args)
(list* ',realname args))))
(defalias path:dirname (pathname) cl-fad:pathname-directory-pathname)
(defun path:basename (pathname) (pathname (file-namestring pathname)))
(defalias path:-e (pathname) cl-fad:file-exists-p)
(defalias path:-d (directory) cl-fad:directory-exists-p)
(defalias path:catfile (&rest pathnames) cl-fad:merge-pathnames-as-file)
(defalias path:catdir (&rest pathnames) cl-fad:merge-pathnames-as-directory)
(defalias path:= (a b) cl-fad:pathname-equal)
(defalias path:absolute-p (pathname) cl-fad:pathname-absolute-p)
(defalias path:relative-p (pathname) cl-fad:pathname-relative-p)
(defalias path:root-p (pathname) cl-fad:pathname-root-p)
(defalias path:rm-r (pathname) cl-fad:delete-directory-and-files)

173
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/temporary-files.lisp Normal file
View file

@ -0,0 +1,173 @@
(in-package :cl-fad)
(defparameter *default-template* "TEMPORARY-FILES:TEMP-%")
(defparameter *max-tries* 10000)
(defvar *name-random-state* (make-random-state t))
;; from XCVB
(eval-when (:load-toplevel :execute)
(defun getenv (x)
"Query the libc runtime environment. See getenv(3)."
(declare (ignorable x))
#+(or abcl clisp xcl) (ext:getenv x)
#+allegro (sys:getenv x)
#+clozure (ccl:getenv x)
#+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
#+cormanlisp
(let* ((buffer (ct:malloc 1))
(cname (ct:lisp-string-to-c-string x))
(needed-size (win:getenvironmentvariable cname buffer 0))
(buffer1 (ct:malloc (1+ needed-size))))
(prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
nil
(ct:c-string-to-lisp-string buffer1))
(ct:free buffer)
(ct:free buffer1)))
#+ecl (si:getenv x)
#+gcl (system:getenv x)
#+lispworks (lispworks:environment-variable x)
#+mcl (ccl:with-cstrs ((name x))
(let ((value (_getenv name)))
(unless (ccl:%null-ptr-p value)
(ccl:%get-cstring value))))
#+sbcl (sb-ext:posix-getenv x)
#+clasp (ext:getenv x)
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl clasp)
(error "~S is not supported on your implementation" 'getenv))
(defun directory-from-environment (environment-variable-name)
(let ((string (getenv environment-variable-name)))
(when (plusp (length string))
(pathname-as-directory string))))
#+win32
(define-condition missing-temp-environment-variable (error)
()
(:report (lambda (condition stream)
(declare (ignore condition))
(format stream "the TEMP environment variable has not been found, cannot continue"))))
#+win32
(defun get-default-temporary-directory ()
(or (directory-from-environment "TEMP")
(error 'missing-temp-environment-variable)))
#-win32
(defun get-default-temporary-directory ()
(or (directory-from-environment "TMPDIR")
(and #-clisp (probe-file #P"/tmp/")
#+clisp (ext:probe-directory #P"/tmp/")
#P"/tmp/")))
(handler-case
(logical-pathname-translations "TEMPORARY-FILES")
(error ()
(alexandria:if-let (default-temporary-directory (get-default-temporary-directory))
(setf (logical-pathname-translations "TEMPORARY-FILES") `(("*.*.*" ,default-temporary-directory)))
(warn "could not automatically determine a default mapping for TEMPORARY-FILES")))))
;; locking for multi-threaded operation with unsafe random function
(defvar *create-file-name-lock* (bordeaux-threads:make-lock "Temporary File Name Creation Lock"))
(defmacro with-file-name-lock-held (() &body body)
`(bordeaux-threads:with-lock-held (*create-file-name-lock*)
,@body))
(defun generate-random-string ()
(with-file-name-lock-held ()
(format nil "~:@(~36,8,'0R~)" (random (expt 36 8) *name-random-state*))))
(define-condition invalid-temporary-pathname-template (error)
((string :initarg :string))
(:report (lambda (condition stream)
(with-slots (string) condition
(format stream "invalid temporary file name template ~S, must contain a percent sign that is to be replaced by a random string" string)))))
(defun generate-random-pathname (template random-string-generator)
(let ((percent-position (or (position #\% template)
(error 'invalid-temporary-pathname-template :string template))))
(merge-pathnames (concatenate 'string
(subseq template 0 percent-position)
(funcall random-string-generator)
(subseq template (1+ percent-position))))))
(define-condition cannot-create-temporary-file (error)
((template :initarg :template)
(max-tries :initarg :max-tries))
(:report (lambda (condition stream)
(with-slots (template max-tries) condition
(format stream "cannot create temporary file with template ~A, giving up after ~D attempt~:P"
template max-tries)))))
(defun open-temporary (&rest open-arguments
&key
(template *default-template*)
(generate-random-string 'generate-random-string)
(max-tries *max-tries*)
(direction :output)
&allow-other-keys)
"Create a file with a randomly generated name and return the opened
stream. The resulting pathname is generated from TEMPLATE, which
is a string representing a pathname template. A percent sign (%)
in that string is replaced by a randomly generated string to make
the filename unique. The default for TEMPLATE places temporary
files in the TEMPORARY-FILES logical pathname host, which is
automatically set up in a system specific manner. The file name
generated from TEMPLATE is merged with *DEFAULT-PATHNAME-DEFAULTS*,
so random pathnames relative to that directory can be generated by
not specifying a directory in TEMPLATE.
GENERATE-RANDOM-STRING can be passed to override the default
function that generates the random name component. It should
return a random string consisting of characters that are permitted
in a pathname (logical or physical, depending on TEMPLATE).
The name of the temporary file can be accessed calling the PATHNAME
function on STREAM. For convenience, the temporary file is opened
on the physical pathname, i.e. if the TEMPLATE designate a logical
pathname the translation to a physical pathname is performed before
opening the stream.
In order to create a unique file name, OPEN-TEMPORARY may loop
internally up to MAX-TRIES times before giving up and signalling a
CANNOT-CREATE-TEMPORARY-FILE condition."
(loop thereis (apply #'open
(translate-logical-pathname (generate-random-pathname template generate-random-string))
:direction direction
:if-exists nil
(alexandria:remove-from-plist open-arguments :template :generate-random-string :max-tries))
repeat max-tries
finally (error 'cannot-create-temporary-file
:template template
:max-tries max-tries)))
(defmacro with-output-to-temporary-file ((stream &rest args) &body body)
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
with STREAM bound to the temporary file stream. Returns the
pathname of the file that has been created. See OPEN-TEMPORARY for
permitted options."
`(with-open-stream (,stream (open-temporary ,@args))
,@body
(pathname ,stream)))
(defmacro with-open-temporary-file ((stream &rest args &key keep &allow-other-keys) &body body)
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
with STREAM bound to the temporary file stream. Returns the values
returned by BODY. By default, the file is deleted when BODY is
exited. If a true value is passed in KEEP, the file is not deleted
when the body is exited. See OPEN-TEMPORARY for more permitted
options."
`(with-open-stream (,stream (open-temporary ,@(alexandria:remove-from-plist args :keep)))
#+sbcl
(declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
,(if (and (constantp keep)
keep)
`(progn ,@body)
`(unwind-protect
(progn ,@body)
(unless ,keep
(close ,stream)
(delete-file (pathname ,stream)))))))

49
sbcl/.quicklisp/dists/quicklisp/software/cl-fad-20190813-git/temporary-files.test.lisp Normal file
View file

@ -0,0 +1,49 @@
(in-package :cl-fad-test)
(deftest 'temporary-file 'with-output-to-temporary-file ()
(let ((pathname (with-output-to-temporary-file (f)
(write-string "hello" f))))
(test-assert (probe-file pathname))
(test-equal (alexandria:read-file-into-string pathname) "hello")
(delete-file pathname)))
(deftest 'temporary-file 'with-open-temporary-file-keep ()
(let ((pathname (with-open-temporary-file (f :keep nil)
(pathname f))))
(test-assert (null (probe-file pathname))))
(let ((pathname (with-open-temporary-file (f :keep t)
(pathname f))))
(test-assert (probe-file pathname))
(delete-file pathname))
(let* ((keep nil)
(pathname (with-open-temporary-file (f :keep keep)
(pathname f))))
(test-assert (null (probe-file pathname))))
(let* ((keep t)
(pathname (with-open-temporary-file (f :keep keep)
(pathname f))))
(test-assert (probe-file pathname))
(delete-file pathname)))
(deftest 'temporary-file 'template-tests ()
;; error is signalled when template does not contain a percent sign.
(let ((*default-template* "foo"))
(test-condition (with-open-temporary-file (f :keep nil))
'invalid-temporary-pathname-template))
;; file name template occurs in generated file name (for logical path name)
(let* ((*default-template* "temporary-files:bla%.txt")
(pathname (with-open-temporary-file (f :keep nil)
(pathname f))))
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname))))
;; file name template occurs in generated file name (for pysical path name)
(let* ((*default-template* (concatenate 'string
(namestring (translate-logical-pathname "temporary-files:"))
"bla%.txt"))
(pathname (with-open-temporary-file (f :keep nil)
(pathname f))))
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname)))))

400
sbcl/.quicklisp/dists/quicklisp/software/cl-ppcre-20190521-git/CHANGELOG Normal file
View file

@ -0,0 +1,400 @@
Version 2.1.1
2019-04-07
Version 2.0.11
2015-08-26
Fix for type checks in LispWorks 7 (Martin Simmons)
Version 2.0.10
2015-05-28
Add :author/:license/:description fields to .asd files (Hans Huebner)
Move inlined definitions before they are used. (Stas Boukarev)
Version 2.0.9
2014-11-28
Merge branch 'master' of github.com:edicl/cl-ppcre (Hans Huebner)
Merge pull request #20 from billitch/master (Hans Huebner)
Typo in CREATE-SCANNER documentation. (Thomas de Grivel)
Version 2.0.8
2014-11-28
Update support info (Hans Huebner)
Version 2.0.7
2014-01-23
Doc: Update repository location, remove the darcs mirror. (Stas Boukarev)
Version 2.0.6
2015-01-05
Fix failing tests and spurious compiler warnings
Version 2.0.5
2014-01-05
Fix spurious test failures (Edi Weitz)
Version 2.0.4
2013-04-13
Rewrite SEQ without using recursion (Stas Boukarev)
:property and :invert-property scanning bug fix (Cyrus Harmon)
Improve documentation (David Lindes)
Version 2.0.3
2009-10-28
Use LW:SIMPLE-TEXT-STRING throughout for LispWorks
Version 2.0.2
2009-09-17
Fixed typo in chartest.lisp (caught by Peter Seibel)
Appease CCL (thanks to Hans Hübner)
Version 2.0.1
2008-09-02
Fixed faulty declaration (caught by Brent Fulgham)
Version 2.0.0
2008-07-24
Added named properties (\p{foo})
Added Unicode support
Introduced test functions for character classes
Added optional test function optimization
Cleaned up test suite, removed performance cruft
Removed the various alternative system definitions (too much maintenance work)
Exported PARSE-STRING
Changed default value of *USE-BMH-MATCHERS*
General cleanup
Lots of documentation additions
Version 1.4.1
2008-07-03
Skip non-characters in CREATE-RANGES-FROM-SET
Version 1.4.0
2008-07-03
Replaced hash tables with charsets (by Nikodemus Siivola)
Get rid of duplicates in REGEX-APROPOS(-LIST)
Version 1.3.3
2008-06-25
Let the Lisp decide how it wants to enlarge its hash tables
Fixed anchors for special variables in docs
Fixed typo in docs (thanks to Jason S. Cornez)
Version 1.3.2
2007-09-13
Updated docs and ChangeLog to be really in sync with 1.3.1 changes (thanks to Sébastien Saint-Sevin)
Version 1.3.1
2007-08-24
Second return value for REGEX-REPLACE and REGEX-REPLACE-ALL (patch by Matthew Sachs)
Version 1.3.0
2007-03-24
Optional support for named registers (patch by Ondrej Svitek)
Version 1.2.19
2007-01-16
Fixed behaviour of look-behind in repeated scans (caught by RegexCoach user Hans Jud)
Version 1.2.18
2006-10-12
Changed default element type for LispWorks
Fixed documentation for REGEX-REPLACE-ALL
Version 1.2.17
2006-10-11
Fixed bug in DO-SCANS which affected anchors (caught by RegexCoach user Laurent Taupiac)
Update link for 'man perlre' (thanks to Ricardo Boccato Alves)
Version 1.2.16
2006-07-16
Added :ELEMENT-TYPE to REGEX-REPLACE(-ALL)
Version 1.2.15
2006-07-03
Added :REGEX tag to parse tree syntax (thanks to Frédéric Jolliton)
Version 1.2.14
2006-05-24
Added missing </code> tag in docs (thanks to Wojciech Kaczmarek)
Fixed IMPORT statement for LW
Version 1.2.13
2005-12-06
Fixed bug involving *REAL-START-POS* (caught by "tichy")
Version 1.2.12
2005-11-01
REGEX-APROPOS-AUX now also uses :INHERITED
Fixed typo in parser.lisp (thanks to Derek Peschel)
Fixed value of *REGEX-CHAR-CODE-LIMIT* in docs and test (thanks to Christophe Rhodes)
Version 1.2.11
2005-08-01
Added external format for SBCL in ppcre-tests.lisp (thanks to Christophe Rhodes)
Version 1.2.10
2005-07-20
Fixed bug in CHAR-SEARCHER-AUX (caught by Peter Schuller)
Don't redefine what's already there (for LispWorks)
Version 1.2.9
2005-06-27
Hide compiler macros from CCL (thanks to Karsten Poeck)
Version 1.2.8
2005-06-10
Change EQ to EQL in REGEX-LENGTH for ANSI conformance and ABCL compatibility (thanks to Peter Graves)
Version 1.2.7
2005-05-16
Added lispworks-defsystem.lisp (thanks to Wade Humeniuk)
Fixed bug in WORD-BOUNDARY-P
Version 1.2.6
2005-04-13
Added some DEFGENERICs to appease SBCL (thanks to Alan Shields)
Removed wrong FTYPE declaration for STR (thanks to Alan Shields)
Version 1.2.5
2005-03-09
Customizable optimize qualities (thanks to Damien Kick)
Version 1.2.4
2005-03-07
Changed DEBUG optimize quality from 0 to 1
Version 1.2.3
2005-02-02
Wrapped WITH-COMPILATION-UNIT around loop in load.lisp
Version 1.2.2
2005-02-02
Fixed bug in hash table optimization (introduced in 1.1.0)
Version 1.2.1
2005-01-25
There was a wrong read-time conditional in api.lisp, sorry
Version 1.2.0
2005-01-24
AllegroCL compatibility mode
Fixed broken load.lisp file (caught by Jim Prewett and Zach Beane)
Version 1.1.0
2005-01-23
Cleaned up load.lisp and cl-ppcre.asd
Make large hash tables smaller, if possible
Correct treatment of constant regular expressions in DO-SCANS
Version 1.0.0
2004-12-22
Special anniversary release... :)
Version 0.9.4
2004-12-18
Fixed bug in NORMALIZE-VAR-LIST (caught by Dave Roberts)
Version 0.9.3
2004-12-09
Fixed bug in CREATE-SCANNER-AUX (caught by Allan Ruttenberg and Gary Byers)
Version 0.9.2
2004-12-06
More compiler macros (thanks to Allan Ruttenberg)
Version 0.9.1
2004-11-29
Shortcuts for REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS (suggested by Alexander Kjeldaas)
Version 0.9.0
2004-10-14
Experimental support for "filters"
Bugfix for standalone regular expressions (ACCUMULATE-START-P wasn't set to NIL)
Version 0.8.1
2004-09-30
Patches for Genera 8.5 (thanks to Patrick O'Donnell)
Version 0.8.0
2004-09-16
Added parse tree synonyms (thanks to Patrick O'Donnell)
Version 0.7.9
2004-07-13
Fixed bug in DO-SCANS (caught by Jan Rychter)
Version 0.7.8
2004-07-13
New SIMPLE-CALLS keyword argument for REGEX-REPLACE(-ALL)
Added environment parameter to compiler macros (thanks to c.l.l article <aczhx5hj.fsf@ccs.neu.edu> by Joe Marshall)
Added compiler macros for SCAN-TO-STRINGS and REGEX-REPLACE(-ALL) (they somehow got lost)
Version 0.7.7
2004-05-19
Fixed bug in NEWLINE-SKIPPER (caught by RegexCoach user Thomas-Paz Hartman)
Added doc strings for PPCRE-SYNTAX-ERROR and friends (after playing with slime-apropos-package)
Added hyperdoc support
Version 0.7.6
2004-04-20
The closures created by CREATE-BMH-MATCHER now cleanly cope with negative arguments (bug caught by Damien Kick)
Version 0.7.5
2004-04-19
Fixed a bug with constant-length repetitions of . (dot) in single-line mode (caught by RegexCoach user Lee Gold)
Version 0.7.4
2004-02-16
Fixed wrong call to SIGNAL-PPCRE-SIGNAL-ERROR in lexer.lisp (caught by Peter Graves)
Added :CL-PPCRE to *FEATURES* (for CL-INTERPOL)
Compiler macro for SPLIT
Version 0.7.3
2004-01-28
Fixed bug in CURRENT-MIN-REST for lookaheads (reported by RegexCoach user Thomas-Paz Hartman)
Added tests for this bug
Version 0.7.2
2004-01-27
Fixed typo (SUBSEQ/NSUBSEQ) in SPLIT (thanks to Alan Ruttenberg)
Updated docs with respect to ECL (thanks to Alex Mizrahi)
Mention FreeBSD port in docs
Version 0.7.1
2003-10-24
Fixed version numbers in docs (thanks to Sébastien Saint-Sevin)
Version 0.7.0
2003-10-23
New macros REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS
Added SHAREP keyword argument to most API functions and macros
Mention CL-INTERPOL in docs
Partial code cleanup (using WITH-UNIQUE-NAMES and REBINDING)
Version 0.6.1
2003-10-11
Added EXTERNAL-FORMAT keyword args to CL-PPCRE-TEST:TEST for some CLs (thanks to JP Massar and Scott D. Kalter)
Fixed bug with REGEX-REPLACE and REGEX-REPLACE-ALL when (= START END) was true
Added doc sections for quoting problems and backslash confusions (thanks to conversations with Peter Seibel)
Disable quoting in definition of QUOTE-SECTIONS so you can always safely rebuild CL-PPCRE
Version 0.6.0
2003-10-07
CL-PPCRE now has its own condition types
Added support for Perl's \Q and \E (Peter Seibel convinced me to do it) - see QUOTE-META-CHARS and *ALLOW-QUOTING*
Added tests for this new feature
Threaded tests are more verbose now and use only keyword args
Version 0.5.9
2003-10-03
Changed "^" optimizations with respect to constant end strings with offsets (bug caught by Yexuan Gui)
Added tests for this bug
Removed *.dos files from CL-PPCRE-TEST tests (thanks to JP Massar)
Added threaded tests for SBCL (thanks to Christophe Rhodes)
Version 0.5.8
2003-09-17
Optimizations for ".*" were too optimistic when look-behinds were involved
Added tests for this bug
Removed *.dos files
Version 0.5.7
2003-08-20
Fixed (CL-PPCRE:SCAN "(.)X$" "ABCX" :START 4) bug (spotted by Tibor Simko)
Forgot to export *REGEX-CHAR-CODE-LIMIT* in Corman version of DEFPACKAGE
Removed Emacs local variables from source code (finally...)
Mention Gentoo in docs
Version 0.5.6
2003-06-30
Replaced wrong COPY-REGEX code for WORD-BOUNDARY objects (detected by Max Goldberg)
Added info about possible TRUENAME problems with ACL in README (thanks to Kevin Layer for providing a patch for this)
Version 0.5.5
2003-06-09
Patch for SBCL/Debian compatibility by Kevin Rosenberg
Simpler version of compiler macro
Availability through asdf-install
Version 0.5.4
2003-04-09
Added DESTRUCTIVE keyword to CREATE-SCANNER
Version 0.5.3
2003-03-31
Fixed bug in REGEX-REPLACE (replacement string couldn't contain literal backslash)
Fixed bug in definition of CHAR-CLASS (since 0.5.0 the hash slot may be NIL - CMUCL's new PCL detects this)
Micro-optimization in INSERT-CHAR-CLASS-TESTER: CHAR-NOT-GREATERP instead of CHAR-DOWNCASE
Version 0.5.2
2003-03-28
Better compiler macro (thanks to Kent M. Pitman)
Version 0.5.1
2003-03-27
Removed compiler macro
Version 0.5.0
2003-03-27
Lexer, parser, and converter mostly re-written to reduce consing and increase speed
Get rid of FIX-POS in lexer and parser, "ism" flags are handled after parsing now
Smaller test suite (again) due to literal embedding of line breaks
Seperate test files for DOS line endings
Replaced constant +REGEX-CHAR-CODE-LIMIT+ with special variable *REGEX-CHAR-CODE-LIMIT*
Version 0.4.1
2003-03-19
Added compiler macro for SCAN
Changed test suite to be nicer to Corman Lisp and ECL (see docs for new syntax)
Incorporated visual feedback (dots) in test suite (thanks to JP Massar)
Added README file
Replaced STRING-LIST-TO-SIMPLE-STRING with a much improved version by JP Massar
Version 0.4.0
2003-02-27
Added *USE-BMH-MATCHER*
Version 0.3.2
2003-02-21
Added load.lisp
Various minor changes for Corman Lisp compatibility (thanks to Karsten Poeck and JP Massar)
Version 0.3.1
2003-01-18
Bugfix in CREATE-SCANNER (didn't work if flags were given and arg was a parse-tree)
Version 0.3.0
2003-01-12
Added new features to REGEX-REPLACE and REGEX-REPLACE-ALL
Version 0.2.0
2003-01-11
Make SPLIT more Perl-compatible, including new keyword parameters
Version 0.1.4
2003-01-10
Don't move "^" and "\A" while iterating with DO-SCANS
Added link to Debian package
Version 0.1.3
2002-12-25
More usable MK:DEFSYSTEM files (courtesy of Hannu Koivisto)
Fixed typo in documentation
Version 0.1.2
2002-12-22
Added version numbers for Debian packaging
Be friendly to case-sensitive ACL images (courtesy of Kevin Rosenberg and Douglas Crosher)
"Fixed" two cases where declarations came after docstrings (because of bugs in Corman Lisp and older CMUCL versions)
Added #-cormanlisp to hide (INCF (THE FIXNUM POS)) from Corman Lisp
Added file doc/benchmarks.2002-12-22.txt
Version 0.1.1
2002-12-21
Added asdf system definitions by Marco Baringer
Small additions to documentation
Correct (Emacs) local variables list in closures.lisp and api.lisp
Added this CHANGELOG
Version 0.1.0
2002-12-20
Initial release

30
sbcl/.quicklisp/dists/quicklisp/software/cl-ppcre-20190521-git/README.md Normal file
View file

@ -0,0 +1,30 @@
# CL-PPCRE - Portable Perl-compatible regular expressions for Common Lisp
## Abstract
CL-PPCRE is a portable regular expression library for Common Lisp
which has the following features:
* It is **compatible with Perl** (especially when used in conjunction
with [cl-interpol](http://weitz.de/cl-interpol/), to allow
compatible parsing of regexp strings).
* It is pretty **fast**.
* It is **portable** between ANSI-compliant Common Lisp
implementations.
* It is **thread-safe**.
* In addition to specifying regular expressions as strings like in
Perl you can also use **S-expressions**.
* It comes with a
**[BSD-style license](http://www.opensource.org/licenses/bsd-license.php)**
so you can basically do with it whatever you want.
CL-PPCRE has been used successfully in various applications like
[BioBike](http://nostoc.stanford.edu/Docs/),
[clutu](http://clutu.com/),
[LoGS](http://www.hpc.unm.edu/~download/LoGS/),
[CafeSpot](http://cafespot.net/),
[Eboy](http://www.eboy.com/), or
[The Regex Coach](http://weitz.de/regex-coach/).
Further documentation can be found in `docs/index.html`, or on
[the cl-ppcre homepage](https://edicl.github.io/cl-ppcre/).

1278
sbcl/.quicklisp/dists/quicklisp/software/cl-ppcre-20190521-git/api.lisp Normal file
View file

File diff suppressed because it is too large Load diff

152
sbcl/.quicklisp/dists/quicklisp/software/cl-ppcre-20190521-git/charmap.lisp Normal file
View file

@ -0,0 +1,152 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/cl-ppcre/charmap.lisp,v 1.19 2009/09/17 19:17:30 edi Exp $
;;; An optimized representation of sets of characters.
;;; Copyright (c) 2008-2009, Dr. Edmund Weitz. 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.
(in-package :cl-ppcre)
(defstruct (charmap (:constructor make-charmap%))
;; a bit vector mapping char codes to "booleans" (1 for set members,
;; 0 for others)
(vector #*0 :type simple-bit-vector)
;; the smallest character code of all characters in the set
(start 0 :type fixnum)
;; the upper (exclusive) bound of all character codes in the set
(end 0 :type fixnum)
;; the number of characters in the set, or NIL if this is unknown
(count nil :type (or fixnum null))
;; whether the charmap actually represents the complement of the set
(complementp nil :type boolean))
;; seems to be necessary for some Lisps like ClozureCL
(defmethod make-load-form ((map charmap) &optional environment)
(make-load-form-saving-slots map :environment environment))
(declaim (inline in-charmap-p))
(defun in-charmap-p (char charmap)
"Tests whether the character CHAR belongs to the set represented by CHARMAP."
(declare #.*standard-optimize-settings*)
(declare (character char) (charmap charmap))
(let* ((char-code (char-code char))
(char-in-vector-p
(let ((charmap-start (charmap-start charmap)))
(declare (fixnum charmap-start))
(and (<= charmap-start char-code)
(< char-code (the fixnum (charmap-end charmap)))
(= 1 (sbit (the simple-bit-vector (charmap-vector charmap))
(- char-code charmap-start)))))))
(cond ((charmap-complementp charmap) (not char-in-vector-p))
(t char-in-vector-p))))
(defun charmap-contents (charmap)
"Returns a list of all characters belonging to a character map.
Only works for non-complement charmaps."
(declare #.*standard-optimize-settings*)
(declare (charmap charmap))
(and (not (charmap-complementp charmap))
(loop for code of-type fixnum from (charmap-start charmap) to (charmap-end charmap)
for i across (the simple-bit-vector (charmap-vector charmap))
when (= i 1)
collect (code-char code))))
(defun make-charmap (start end test-function &optional complementp)
"Creates and returns a charmap representing all characters with
character codes in the interval [start end) that satisfy
TEST-FUNCTION. The COMPLEMENTP slot of the charmap is set to the
value of the optional argument, but this argument doesn't have an
effect on how TEST-FUNCTION is used."
(declare #.*standard-optimize-settings*)
(declare (fixnum start end))
(let ((vector (make-array (- end start) :element-type 'bit))
(count 0))
(declare (fixnum count))
(loop for code from start below end
for char = (code-char code)
for index from 0
when char do
(incf count)
(setf (sbit vector index) (if (funcall test-function char) 1 0)))
(make-charmap% :vector vector
:start start
:end end
;; we don't know for sure if COMPLEMENTP is true as
;; there isn't a necessary a character for each
;; integer below *REGEX-CHAR-CODE-LIMIT*
:count (and (not complementp) count)
;; make sure it's boolean
:complementp (not (not complementp)))))
(defun create-charmap-from-test-function (test-function start end)
"Creates and returns a charmap representing all characters with
character codes between START and END which satisfy TEST-FUNCTION.
Tries to find the smallest interval which is necessary to represent
the character set and uses the complement representation if that
helps."
(declare #.*standard-optimize-settings*)
(let (start-in end-in start-out end-out)
;; determine the smallest intervals containing the set and its
;; complement, [start-in, end-in) and [start-out, end-out) - first
;; the lower bound
(loop for code from start below end
for char = (code-char code)
until (and start-in start-out)
when (and char
(not start-in)
(funcall test-function char))
do (setq start-in code)
when (and char
(not start-out)
(not (funcall test-function char)))
do (setq start-out code))
(unless start-in
;; no character satisfied the test, so return a "pseudo" charmap
;; where IN-CHARMAP-P is always false
(return-from create-charmap-from-test-function
(make-charmap% :count 0)))
(unless start-out
;; no character failed the test, so return a "pseudo" charmap
;; where IN-CHARMAP-P is always true
(return-from create-charmap-from-test-function
(make-charmap% :complementp t)))
;; now determine upper bound
(loop for code from (1- end) downto start
for char = (code-char code)
until (and end-in end-out)
when (and char
(not end-in)
(funcall test-function char))
do (setq end-in (1+ code))
when (and char
(not end-out)
(not (funcall test-function char)))
do (setq end-out (1+ code)))
;; use the smaller interval
(cond ((<= (- end-in start-in) (- end-out start-out))
(make-charmap start-in end-in test-function))
(t (make-charmap start-out end-out (complement* test-function) t)))))

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