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

sbcl stuff

Browse source
This commit is contained in:
Ian Keane 2020-01-20 14:13:08 -05:00
parent 1d1dbc34df
commit 5d91dbb667
335 changed files with 119806 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

4516
sbcl/.quicklisp/asdf.lisp Normal file
View file

File diff suppressed because it is too large Load diff

28
sbcl/.quicklisp/client-info.sexp Normal file
View file

@ -0,0 +1,28 @@
(:version "2020-01-04"
:client-info-format "1"
:subscription-url
"http://beta.quicklisp.org/client/quicklisp.sexp"
:canonical-client-info-url
"http://beta.quicklisp.org/client/2020-01-04/client-info.sexp"
:client-tar
(:url "http://beta.quicklisp.org/client/2020-01-04/quicklisp.tar"
:size 256000
:md5 "1ac647d2f5735d9fa57d88f982e07970"
:sha256
"3d8d0a8f0aee3a510c343bb3bcf668e5d327e992412ce98634c7d24c9881b9b8")
:setup
(:url "http://beta.quicklisp.org/client/2015-09-24/setup.lisp"
:size 5054
:md5 "bc380ac2e8296a67caba954802998bd4"
:sha256
"2a7fbb8dbda22bb932ad12898f2ad3ebf1e770a4d0992cf4a2debe5739e35801")
:asdf
(:url "http://beta.quicklisp.org/asdf/2.26/asdf.lisp"
:size 198729
:md5 "6c2702561f5b8f02acd40d08c5429c96"
:sha256
"def6bac208961aedf7e9593c3106adb3474241370f84ad1438a5f1d6632d4a7f"))

BIN
sbcl/.quicklisp/dists/quicklisp/archives/alexandria-20191227-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/slime-v2.24.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/split-sequence-v2.0.0.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/trivial-gray-streams-20181018-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/usocket-0.8.3.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/vom-20160825-git.tgz Normal file
View file

Binary file not shown.

BIN
sbcl/.quicklisp/dists/quicklisp/archives/yason-v0.7.8.tgz Normal file
View file

Binary file not shown.

7
sbcl/.quicklisp/dists/quicklisp/distinfo.txt Normal file
View file

@ -0,0 +1,7 @@
name: quicklisp
version: 2019-12-27
system-index-url: http://beta.quicklisp.org/dist/quicklisp/2019-12-27/systems.txt
release-index-url: http://beta.quicklisp.org/dist/quicklisp/2019-12-27/releases.txt
archive-base-url: http://beta.quicklisp.org/
canonical-distinfo-url: http://beta.quicklisp.org/dist/quicklisp/2019-12-27/distinfo.txt
distinfo-subscription-url: http://beta.quicklisp.org/dist/quicklisp.txt

0
sbcl/.quicklisp/dists/quicklisp/enabled.txt Normal file
View file

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

@ -0,0 +1 @@
dists/quicklisp/software/alexandria-20191227-git/

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

@ -0,0 +1 @@
dists/quicklisp/software/slime-v2.24/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/split-sequence.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/split-sequence-v2.0.0/

1
sbcl/.quicklisp/dists/quicklisp/installed/releases/trivial-gray-streams.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/trivial-gray-streams-20181018-git/

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

@ -0,0 +1 @@
dists/quicklisp/software/usocket-0.8.3/

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

@ -0,0 +1 @@
dists/quicklisp/software/vom-20160825-git/

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

@ -0,0 +1 @@
dists/quicklisp/software/yason-v0.7.8/

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/alexandria-tests.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/alexandria-20191227-git/alexandria.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/split-sequence.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/split-sequence-v2.0.0/split-sequence.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/slime-v2.24/swank.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams-test.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/trivial-gray-streams.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd

1
sbcl/.quicklisp/dists/quicklisp/installed/systems/usocket-server.txt Normal file
View file

@ -0,0 +1 @@
dists/quicklisp/software/usocket-0.8.3/usocket-server.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/usocket-0.8.3/usocket-test.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/usocket-0.8.3/usocket.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/vom-20160825-git/vom.asd

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

@ -0,0 +1 @@
dists/quicklisp/software/yason-v0.7.8/yason.asd

1
sbcl/.quicklisp/dists/quicklisp/preference.txt Normal file
View file

@ -0,0 +1 @@
3788524139

BIN
sbcl/.quicklisp/dists/quicklisp/releases.cdb Normal file
View file

Binary file not shown.

1831
sbcl/.quicklisp/dists/quicklisp/releases.txt Normal file
View file

File diff suppressed because one or more lines are too long

13
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.boring Normal file
View file

@ -0,0 +1,13 @@
# Boring file regexps:
~$
^_darcs
^\{arch\}
^.arch-ids
\#
\.dfsl$
\.ppcf$
\.fasl$
\.x86f$
\.fas$
\.lib$
^public_html

4
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
*.fasl
*~
\#*
*.patch

9
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/AUTHORS Normal file
View file

@ -0,0 +1,9 @@
ACTA EST FABULA PLAUDITE
Nikodemus Siivola
Attila Lendvai
Marco Baringer
Robert Strandh
Luis Oliveira
Tobias C. Rittweiler

37
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/LICENCE Normal file
View file

@ -0,0 +1,37 @@
Alexandria software and associated documentation are in the public
domain:
Authors dedicate this work to public domain, for the benefit of the
public at large and to the detriment of the authors' heirs and
successors. Authors intends this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights under
copyright law, whether vested or contingent, in the work. Authors
understands that such relinquishment of all rights includes the
relinquishment of all rights to enforce (by lawsuit or otherwise)
those copyrights in the work.
Authors recognize that, once placed in the public domain, the work
may be freely reproduced, distributed, transmitted, used, modified,
built upon, or otherwise exploited by anyone for any purpose,
commercial or non-commercial, and in any way, including by methods
that have not yet been invented or conceived.
In those legislations where public domain dedications are not
recognized or possible, Alexandria is distributed under the following
terms and conditions:
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 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.

52
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/README Normal file
View file

@ -0,0 +1,52 @@
Alexandria is a collection of portable public domain utilities that
meet the following constraints:
* Utilities, not extensions: Alexandria will not contain conceptual
extensions to Common Lisp, instead limiting itself to tools and
utilities that fit well within the framework of standard ANSI
Common Lisp. Test-frameworks, system definitions, logging
facilities, serialization layers, etc. are all outside the scope of
Alexandria as a library, though well within the scope of Alexandria
as a project.
* Conservative: Alexandria limits itself to what project members
consider conservative utilities. Alexandria does not and will not
include anaphoric constructs, loop-like binding macros, etc.
* Portable: Alexandria limits itself to portable parts of Common
Lisp. Even apparently conservative and useful functions remain
outside the scope of Alexandria if they cannot be implemented
portably. Portability is here defined as portable within a
conforming implementation: implementation bugs are not considered
portability issues.
Homepage:
http://common-lisp.net/project/alexandria/
Mailing lists:
http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
Repository:
git://common-lisp.net/projects/alexandria/alexandria.git
Documentation:
http://common-lisp.net/project/alexandria/draft/alexandria.html
(To build docs locally: cd doc && make html pdf info)
Patches:
Patches are always welcome! Please send them to the mailing list as
attachments, generated by "git format-patch -1".
Patches should include a commit message that explains what's being
done and /why/, and when fixing a bug or adding a feature you should
also include a test-case.
Be advised though that right now new features are unlikely to be
accepted until 1.0 is officially out of the door.

11
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria-tests.asd Normal file
View file

@ -0,0 +1,11 @@
(defsystem "alexandria-tests"
:licence "Public Domain / 0-clause MIT"
:description "Tests for Alexandria, which is a collection of portable public domain utilities."
:author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
:depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
:components ((:file "tests"))
:perform (test-op (o c)
(flet ((run-tests (&rest args)
(apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
(run-tests :compiled nil)
(run-tests :compiled t))))

62
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/alexandria.asd Normal file
View file

@ -0,0 +1,62 @@
(defsystem "alexandria"
:version "1.0.0"
:licence "Public Domain / 0-clause MIT"
:description "Alexandria is a collection of portable public domain utilities."
:author "Nikodemus Siivola and others."
:long-description
"Alexandria is a project and a library.
As a project Alexandria's goal is to reduce duplication of effort and improve
portability of Common Lisp code according to its own idiosyncratic and rather
conservative aesthetic.
As a library Alexandria is one of the means by which the project strives for
its goals.
Alexandria is a collection of portable public domain utilities that meet
the following constraints:
* Utilities, not extensions: Alexandria will not contain conceptual
extensions to Common Lisp, instead limiting itself to tools and utilities
that fit well within the framework of standard ANSI Common Lisp.
Test-frameworks, system definitions, logging facilities, serialization
layers, etc. are all outside the scope of Alexandria as a library, though
well within the scope of Alexandria as a project.
* Conservative: Alexandria limits itself to what project members consider
conservative utilities. Alexandria does not and will not include anaphoric
constructs, loop-like binding macros, etc.
Also, its exported symbols are being imported by many other packages
already, so each new export carries the danger of causing conflicts.
* Portable: Alexandria limits itself to portable parts of Common Lisp. Even
apparently conservative and useful functions remain outside the scope of
Alexandria if they cannot be implemented portably. Portability is here
defined as portable within a conforming implementation: implementation bugs
are not considered portability issues.
* Team player: Alexandria will not (initially, at least) subsume or provide
functionality for which good-quality special-purpose packages exist, like
split-sequence. Instead, third party packages such as that may be
\"blessed\"."
:components
((:static-file "LICENCE")
(:static-file "tests.lisp")
(:file "package")
(:file "definitions" :depends-on ("package"))
(:file "binding" :depends-on ("package"))
(:file "strings" :depends-on ("package"))
(:file "conditions" :depends-on ("package"))
(:file "io" :depends-on ("package" "macros" "lists" "types"))
(:file "macros" :depends-on ("package" "strings" "symbols"))
(:file "hash-tables" :depends-on ("package" "macros"))
(:file "control-flow" :depends-on ("package" "definitions" "macros"))
(:file "symbols" :depends-on ("package"))
(:file "functions" :depends-on ("package" "symbols" "macros"))
(:file "lists" :depends-on ("package" "functions"))
(:file "types" :depends-on ("package" "symbols" "lists"))
(:file "arrays" :depends-on ("package" "types"))
(:file "sequences" :depends-on ("package" "lists" "types"))
(:file "numbers" :depends-on ("package" "sequences"))
(:file "features" :depends-on ("package" "control-flow")))
:in-order-to ((test-op (test-op "alexandria-tests"))))

18
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/arrays.lisp Normal file
View file

@ -0,0 +1,18 @@
(in-package :alexandria)
(defun copy-array (array &key (element-type (array-element-type array))
(fill-pointer (and (array-has-fill-pointer-p array)
(fill-pointer array)))
(adjustable (adjustable-array-p array)))
"Returns an undisplaced copy of ARRAY, with same fill-pointer and
adjustability (if any) as the original, unless overridden by the keyword
arguments."
(let* ((dimensions (array-dimensions array))
(new-array (make-array dimensions
:element-type element-type
:adjustable adjustable
:fill-pointer fill-pointer)))
(dotimes (i (array-total-size array))
(setf (row-major-aref new-array i)
(row-major-aref array i)))
new-array))

90
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/binding.lisp Normal file
View file

@ -0,0 +1,90 @@
(in-package :alexandria)
(defmacro if-let (bindings &body (then-form &optional else-form))
"Creates new variable bindings, and conditionally executes either
THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
BINDINGS must be either single binding of the form:
(variable initial-form)
or a list of bindings of the form:
((variable-1 initial-form-1)
(variable-2 initial-form-2)
...
(variable-n initial-form-n))
All initial-forms are executed sequentially in the specified order. Then all
the variables are bound to the corresponding values.
If all variables were bound to true values, the THEN-FORM is executed with the
bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
effect."
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings))
(variables (mapcar #'car binding-list)))
`(let ,binding-list
(if (and ,@variables)
,then-form
,else-form))))
(defmacro when-let (bindings &body forms)
"Creates new variable bindings, and conditionally executes FORMS.
BINDINGS must be either single binding of the form:
(variable initial-form)
or a list of bindings of the form:
((variable-1 initial-form-1)
(variable-2 initial-form-2)
...
(variable-n initial-form-n))
All initial-forms are executed sequentially in the specified order. Then all
the variables are bound to the corresponding values.
If all variables were bound to true values, then FORMS are executed as an
implicit PROGN."
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings))
(variables (mapcar #'car binding-list)))
`(let ,binding-list
(when (and ,@variables)
,@forms))))
(defmacro when-let* (bindings &body body)
"Creates new variable bindings, and conditionally executes BODY.
BINDINGS must be either single binding of the form:
(variable initial-form)
or a list of bindings of the form:
((variable-1 initial-form-1)
(variable-2 initial-form-2)
...
(variable-n initial-form-n))
Each INITIAL-FORM is executed in turn, and the variable bound to the
corresponding value. INITIAL-FORM expressions can refer to variables
previously bound by the WHEN-LET*.
Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL.
If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit
PROGN."
(let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
(list bindings)
bindings)))
(labels ((bind (bindings body)
(if bindings
`(let (,(car bindings))
(when ,(caar bindings)
,(bind (cdr bindings) body)))
`(progn ,@body))))
(bind binding-list body))))

91
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/conditions.lisp Normal file
View file

@ -0,0 +1,91 @@
(in-package :alexandria)
(defun required-argument (&optional name)
"Signals an error for a missing argument of NAME. Intended for
use as an initialization form for structure and class-slots, and
a default value for required keyword arguments."
(error "Required argument ~@[~S ~]missing." name))
(define-condition simple-style-warning (simple-warning style-warning)
())
(defun simple-style-warning (message &rest args)
(warn 'simple-style-warning :format-control message :format-arguments args))
;; We don't specify a :report for simple-reader-error to let the
;; underlying implementation report the line and column position for
;; us. Unfortunately this way the message from simple-error is not
;; displayed, unless there's special support for that in the
;; implementation. But even then it's still inspectable from the
;; debugger...
(define-condition simple-reader-error
#-sbcl(simple-error reader-error)
#+sbcl(sb-int:simple-reader-error)
())
(defun simple-reader-error (stream message &rest args)
(error 'simple-reader-error
:stream stream
:format-control message
:format-arguments args))
(define-condition simple-parse-error (simple-error parse-error)
())
(defun simple-parse-error (message &rest args)
(error 'simple-parse-error
:format-control message
:format-arguments args))
(define-condition simple-program-error (simple-error program-error)
())
(defun simple-program-error (message &rest args)
(error 'simple-program-error
:format-control message
:format-arguments args))
(defmacro ignore-some-conditions ((&rest conditions) &body body)
"Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
list determines which specific conditions are to be ignored."
`(handler-case
(progn ,@body)
,@(loop for condition in conditions collect
`(,condition (c) (values nil c)))))
(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
"Like CL:UNWIND-PROTECT, but you can specify the circumstances that
the cleanup CLAUSES are run.
clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
Clauses can be given in any order, and more than one clause can be
given for each circumstance. The clauses whose denoted circumstance
occured, are executed in the order the clauses appear.
ABORT-FLAG is the name of a variable that will be bound to T in
CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
otherwise.
Examples:
(unwind-protect-case ()
(protected-form)
(:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
(:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
(:always (format t \"This is evaluated in either case.~%\")))
(unwind-protect-case (aborted-p)
(protected-form)
(:always (perform-cleanup-if aborted-p)))
"
(check-type abort-flag (or null symbol))
(let ((gflag (gensym "FLAG+")))
`(let ((,gflag t))
(unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
(let ,(and abort-flag `((,abort-flag ,gflag)))
,@(loop for (cleanup-kind . forms) in clauses
collect (ecase cleanup-kind
(:normal `(when (not ,gflag) ,@forms))
(:abort `(when ,gflag ,@forms))
(:always `(progn ,@forms)))))))))

106
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/control-flow.lisp Normal file
View file

@ -0,0 +1,106 @@
(in-package :alexandria)
(defun extract-function-name (spec)
"Useful for macros that want to mimic the functional interface for functions
like #'eq and 'eq."
(if (and (consp spec)
(member (first spec) '(quote function)))
(second spec)
spec))
(defun generate-switch-body (whole object clauses test key &optional default)
(with-gensyms (value)
(setf test (extract-function-name test))
(setf key (extract-function-name key))
(when (and (consp default)
(member (first default) '(error cerror)))
(setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
,value ',test)))
`(let ((,value (,key ,object)))
(cond ,@(mapcar (lambda (clause)
(if (member (first clause) '(t otherwise))
(progn
(when default
(error "Multiple default clauses or illegal use of a default clause in ~S."
whole))
(setf default `(progn ,@(rest clause)))
'(()))
(destructuring-bind (key-form &body forms) clause
`((,test ,value ,key-form)
,@forms))))
clauses)
(t ,default)))))
(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Evaluates first matching clause, returning its values, or evaluates and
returns the values of T or OTHERWISE if no keys match."
(generate-switch-body whole object clauses test key))
(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Like SWITCH, but signals an error if no key matches."
(generate-switch-body whole object clauses test key '(error)))
(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
&body clauses)
"Like SWITCH, but signals a continuable error if no key matches."
(generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
(defmacro whichever (&rest possibilities &environment env)
"Evaluates exactly one of POSSIBILITIES, chosen at random."
(setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
(if (every (lambda (p) (constantp p)) possibilities)
`(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
(labels ((expand (possibilities position random-number)
(if (null (cdr possibilities))
(car possibilities)
(let* ((length (length possibilities))
(half (truncate length 2))
(second-half (nthcdr half possibilities))
(first-half (butlast possibilities (- length half))))
`(if (< ,random-number ,(+ position half))
,(expand first-half position random-number)
,(expand second-half (+ position half) random-number))))))
(with-gensyms (random-number)
(let ((length (length possibilities)))
`(let ((,random-number (random ,length)))
,(expand possibilities 0 random-number)))))))
(defmacro xor (&rest datums)
"Evaluates its arguments one at a time, from left to right. If more than one
argument evaluates to a true value no further DATUMS are evaluated, and NIL is
returned as both primary and secondary value. If exactly one argument
evaluates to true, its value is returned as the primary value after all the
arguments have been evaluated, and T is returned as the secondary value. If no
arguments evaluate to true NIL is retuned as primary, and T as secondary
value."
(with-gensyms (xor tmp true)
`(let (,tmp ,true)
(block ,xor
,@(mapcar (lambda (datum)
`(if (setf ,tmp ,datum)
(if ,true
(return-from ,xor (values nil nil))
(setf ,true ,tmp))))
datums)
(return-from ,xor (values ,true t))))))
(defmacro nth-value-or (nth-value &body forms)
"Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
of the forms is true. It then returns all the values returned by evaluating
that form. If none of the forms return a true nth value, this form returns
NIL."
(once-only (nth-value)
(with-gensyms (values)
`(let ((,values (multiple-value-list ,(first forms))))
(if (nth ,nth-value ,values)
(values-list ,values)
,(if (rest forms)
`(nth-value-or ,nth-value ,@(rest forms))
nil))))))
(defmacro multiple-value-prog2 (first-form second-form &body forms)
"Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
all the value returned by SECOND-FORM."
`(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))

37
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/definitions.lisp Normal file
View file

@ -0,0 +1,37 @@
(in-package :alexandria)
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
value
(let ((old (symbol-value name))
(new value))
(if (not (constantp name))
(prog1 new
(cerror "Try to redefine the variable as a constant."
"~@<~S is an already bound non-constant variable ~
whose value is ~S.~:@>" name old))
(if (funcall test old new)
old
(restart-case
(error "~@<~S is an already defined constant whose value ~
~S is not equal to the provided initial value ~S ~
under ~S.~:@>" name old new test)
(ignore ()
:report "Retain the current value."
old)
(continue ()
:report "Try to redefine the constant."
new)))))))
(defmacro define-constant (name initial-value &key (test ''eql) documentation)
"Ensures that the global variable named by NAME is a constant with a value
that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
becomes the documentation string of the constant.
Signals an error if NAME is already a bound non-constant variable.
Signals an error if NAME is already a constant variable whose value is not
equal under TEST to result of evaluating INITIAL-VALUE."
`(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
,@(when documentation `(,documentation))))

3
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
alexandria
include

28
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/Makefile Normal file
View file

@ -0,0 +1,28 @@
.PHONY: clean html pdf include clean-include clean-crap info doc
doc: pdf html info clean-crap
clean-include:
rm -rf include
clean-crap:
rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
clean: clean-include
rm -f *.pdf *.html *.info
include:
sbcl --no-userinit --eval '(require :asdf)' \
--eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
--load docstrings.lisp \
--eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
--eval '(quit)'
pdf: include
texi2pdf alexandria.texinfo
html: include
makeinfo --html --no-split alexandria.texinfo
info: include
makeinfo alexandria.texinfo

277
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/alexandria.texinfo Normal file
View file

@ -0,0 +1,277 @@
\input texinfo @c -*-texinfo-*-
@c %**start of header
@setfilename alexandria.info
@settitle Alexandria Manual
@c %**end of header
@settitle Alexandria Manual -- draft version
@c for install-info
@dircategory Software development
@direntry
* alexandria: Common Lisp utilities.
@end direntry
@copying
Alexandria software and associated documentation are in the public
domain:
@quotation
Authors dedicate this work to public domain, for the benefit of the
public at large and to the detriment of the authors' heirs and
successors. Authors intends this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights under
copyright law, whether vested or contingent, in the work. Authors
understands that such relinquishment of all rights includes the
relinquishment of all rights to enforce (by lawsuit or otherwise)
those copyrights in the work.
Authors recognize that, once placed in the public domain, the work
may be freely reproduced, distributed, transmitted, used, modified,
built upon, or otherwise exploited by anyone for any purpose,
commercial or non-commercial, and in any way, including by methods
that have not yet been invented or conceived.
@end quotation
In those legislations where public domain dedications are not
recognized or possible, Alexandria is distributed under the following
terms and conditions:
@quotation
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation files
(the "Software"), to deal in the Software without restriction,
including without limitation the rights to use, copy, modify, merge,
publish, distribute, sublicense, and/or sell copies of the Software,
and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@end quotation
@end copying
@titlepage
@title Alexandria Manual
@subtitle draft version
@c The following two commands start the copyright page.
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ifnottex
@include include/ifnottex.texinfo
@node Top
@comment node-name, next, previous, up
@top Alexandria
@insertcopying
@menu
* Hash Tables::
* Data and Control Flow::
* Conses::
* Sequences::
* IO::
* Macro Writing::
* Symbols::
* Arrays::
* Types::
* Numbers::
@end menu
@end ifnottex
@node Hash Tables
@comment node-name, next, previous, up
@chapter Hash Tables
@include include/macro-alexandria-ensure-gethash.texinfo
@include include/fun-alexandria-copy-hash-table.texinfo
@include include/fun-alexandria-maphash-keys.texinfo
@include include/fun-alexandria-maphash-values.texinfo
@include include/fun-alexandria-hash-table-keys.texinfo
@include include/fun-alexandria-hash-table-values.texinfo
@include include/fun-alexandria-hash-table-alist.texinfo
@include include/fun-alexandria-hash-table-plist.texinfo
@include include/fun-alexandria-alist-hash-table.texinfo
@include include/fun-alexandria-plist-hash-table.texinfo
@node Data and Control Flow
@comment node-name, next, previous, up
@chapter Data and Control Flow
@include include/macro-alexandria-define-constant.texinfo
@include include/macro-alexandria-destructuring-case.texinfo
@include include/macro-alexandria-ensure-functionf.texinfo
@include include/macro-alexandria-multiple-value-prog2.texinfo
@include include/macro-alexandria-named-lambda.texinfo
@include include/macro-alexandria-nth-value-or.texinfo
@include include/macro-alexandria-if-let.texinfo
@include include/macro-alexandria-when-let.texinfo
@include include/macro-alexandria-when-let-star.texinfo
@include include/macro-alexandria-switch.texinfo
@include include/macro-alexandria-cswitch.texinfo
@include include/macro-alexandria-eswitch.texinfo
@include include/macro-alexandria-whichever.texinfo
@include include/macro-alexandria-xor.texinfo
@include include/fun-alexandria-disjoin.texinfo
@include include/fun-alexandria-conjoin.texinfo
@include include/fun-alexandria-compose.texinfo
@include include/fun-alexandria-ensure-function.texinfo
@include include/fun-alexandria-multiple-value-compose.texinfo
@include include/fun-alexandria-curry.texinfo
@include include/fun-alexandria-rcurry.texinfo
@node Conses
@comment node-name, next, previous, up
@chapter Conses
@include include/type-alexandria-proper-list.texinfo
@include include/type-alexandria-circular-list.texinfo
@include include/macro-alexandria-appendf.texinfo
@include include/macro-alexandria-nconcf.texinfo
@include include/macro-alexandria-remove-from-plistf.texinfo
@include include/macro-alexandria-delete-from-plistf.texinfo
@include include/macro-alexandria-reversef.texinfo
@include include/macro-alexandria-nreversef.texinfo
@include include/macro-alexandria-unionf.texinfo
@include include/macro-alexandria-nunionf.texinfo
@include include/macro-alexandria-doplist.texinfo
@include include/fun-alexandria-circular-list-p.texinfo
@include include/fun-alexandria-circular-tree-p.texinfo
@include include/fun-alexandria-proper-list-p.texinfo
@include include/fun-alexandria-alist-plist.texinfo
@include include/fun-alexandria-plist-alist.texinfo
@include include/fun-alexandria-circular-list.texinfo
@include include/fun-alexandria-make-circular-list.texinfo
@include include/fun-alexandria-ensure-car.texinfo
@include include/fun-alexandria-ensure-cons.texinfo
@include include/fun-alexandria-ensure-list.texinfo
@include include/fun-alexandria-flatten.texinfo
@include include/fun-alexandria-lastcar.texinfo
@include include/fun-alexandria-setf-lastcar.texinfo
@include include/fun-alexandria-proper-list-length.texinfo
@include include/fun-alexandria-mappend.texinfo
@include include/fun-alexandria-map-product.texinfo
@include include/fun-alexandria-remove-from-plist.texinfo
@include include/fun-alexandria-delete-from-plist.texinfo
@include include/fun-alexandria-set-equal.texinfo
@include include/fun-alexandria-setp.texinfo
@node Sequences
@comment node-name, next, previous, up
@chapter Sequences
@include include/type-alexandria-proper-sequence.texinfo
@include include/macro-alexandria-deletef.texinfo
@include include/macro-alexandria-removef.texinfo
@include include/fun-alexandria-rotate.texinfo
@include include/fun-alexandria-shuffle.texinfo
@include include/fun-alexandria-random-elt.texinfo
@include include/fun-alexandria-emptyp.texinfo
@include include/fun-alexandria-sequence-of-length-p.texinfo
@include include/fun-alexandria-length-equals.texinfo
@include include/fun-alexandria-copy-sequence.texinfo
@include include/fun-alexandria-first-elt.texinfo
@include include/fun-alexandria-setf-first-elt.texinfo
@include include/fun-alexandria-last-elt.texinfo
@include include/fun-alexandria-setf-last-elt.texinfo
@include include/fun-alexandria-starts-with.texinfo
@include include/fun-alexandria-starts-with-subseq.texinfo
@include include/fun-alexandria-ends-with.texinfo
@include include/fun-alexandria-ends-with-subseq.texinfo
@include include/fun-alexandria-map-combinations.texinfo
@include include/fun-alexandria-map-derangements.texinfo
@include include/fun-alexandria-map-permutations.texinfo
@node IO
@comment node-name, next, previous, up
@chapter IO
@include include/fun-alexandria-read-stream-content-into-string.texinfo
@include include/fun-alexandria-read-file-into-string.texinfo
@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
@include include/fun-alexandria-read-file-into-byte-vector.texinfo
@node Macro Writing
@comment node-name, next, previous, up
@chapter Macro Writing
@include include/macro-alexandria-once-only.texinfo
@include include/macro-alexandria-with-gensyms.texinfo
@include include/macro-alexandria-with-unique-names.texinfo
@include include/fun-alexandria-featurep.texinfo
@include include/fun-alexandria-parse-body.texinfo
@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
@node Symbols
@comment node-name, next, previous, up
@chapter Symbols
@include include/fun-alexandria-ensure-symbol.texinfo
@include include/fun-alexandria-format-symbol.texinfo
@include include/fun-alexandria-make-keyword.texinfo
@include include/fun-alexandria-make-gensym.texinfo
@include include/fun-alexandria-make-gensym-list.texinfo
@include include/fun-alexandria-symbolicate.texinfo
@node Arrays
@comment node-name, next, previous, up
@chapter Arrays
@include include/type-alexandria-array-index.texinfo
@include include/type-alexandria-array-length.texinfo
@include include/fun-alexandria-copy-array.texinfo
@node Types
@comment node-name, next, previous, up
@chapter Types
@include include/type-alexandria-string-designator.texinfo
@include include/macro-alexandria-coercef.texinfo
@include include/fun-alexandria-of-type.texinfo
@include include/fun-alexandria-type-equals.texinfo
@node Numbers
@comment node-name, next, previous, up
@chapter Numbers
@include include/macro-alexandria-maxf.texinfo
@include include/macro-alexandria-minf.texinfo
@include include/fun-alexandria-binomial-coefficient.texinfo
@include include/fun-alexandria-count-permutations.texinfo
@include include/fun-alexandria-clamp.texinfo
@include include/fun-alexandria-lerp.texinfo
@include include/fun-alexandria-factorial.texinfo
@include include/fun-alexandria-subfactorial.texinfo
@include include/fun-alexandria-gaussian-random.texinfo
@include include/fun-alexandria-iota.texinfo
@include include/fun-alexandria-map-iota.texinfo
@include include/fun-alexandria-mean.texinfo
@include include/fun-alexandria-median.texinfo
@include include/fun-alexandria-variance.texinfo
@include include/fun-alexandria-standard-deviation.texinfo
@bye

881
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/doc/docstrings.lisp Normal file
View file

@ -0,0 +1,881 @@
;;; -*- lisp -*-
;;;; A docstring extractor for the sbcl manual. Creates
;;;; @include-ready documentation from the docstrings of exported
;;;; symbols of specified packages.
;;;; This software is part of the SBCL software system. SBCL is in the
;;;; public domain and is provided with absolutely no warranty. See
;;;; the COPYING file for more information.
;;;;
;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
;;;; by Nikodemus Siivola.
;;;; TODO
;;;; * Verbatim text
;;;; * Quotations
;;;; * Method documentation untested
;;;; * Method sorting, somehow
;;;; * Index for macros & constants?
;;;; * This is getting complicated enough that tests would be good
;;;; * Nesting (currently only nested itemizations work)
;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
;;;; easily generated)
;;;; FIXME: The description below is no longer complete. This
;;;; should possibly be turned into a contrib with proper documentation.
;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
;;;;
;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
;;;; the argument list of the defun / defmacro.
;;;;
;;;; Lines starting with * or - that are followed by intented lines
;;;; are marked up with @itemize.
;;;;
;;;; Lines containing only a SYMBOL that are followed by indented
;;;; lines are marked up as @table @code, with the SYMBOL as the item.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-introspect))
(defpackage :sb-texinfo
(:use :cl :sb-mop)
(:shadow #:documentation)
(:export #:generate-includes #:document-package)
(:documentation
"Tools to generate TexInfo documentation from docstrings."))
(in-package :sb-texinfo)
;;;; various specials and parameters
(defvar *texinfo-output*)
(defvar *texinfo-variables*)
(defvar *documentation-package*)
(defvar *base-package*)
(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
(defparameter *documentation-types*
'(compiler-macro
function
method-combination
setf
;;structure ; also handled by `type'
type
variable)
"A list of symbols accepted as second argument of `documentation'")
(defparameter *character-replacements*
'((#\* . "star") (#\/ . "slash") (#\+ . "plus")
(#\< . "lt") (#\> . "gt")
(#\= . "equals"))
"Characters and their replacement names that `alphanumize' uses. If
the replacements contain any of the chars they're supposed to replace,
you deserve to lose.")
(defparameter *characters-to-drop* '(#\\ #\` #\')
"Characters that should be removed by `alphanumize'.")
(defparameter *texinfo-escaped-chars* "@{}"
"Characters that must be escaped with #\@ for Texinfo.")
(defparameter *itemize-start-characters* '(#\* #\-)
"Characters that might start an itemization in docstrings when
at the start of a line.")
(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
"List of characters that make up symbols in a docstring.")
(defparameter *symbol-delimiters* " ,.!?;")
(defparameter *ordered-documentation-kinds*
'(package type structure condition class macro))
;;;; utilities
(defun flatten (list)
(cond ((null list)
nil)
((consp (car list))
(nconc (flatten (car list)) (flatten (cdr list))))
((null (cdr list))
(cons (car list) nil))
(t
(cons (car list) (flatten (cdr list))))))
(defun whitespacep (char)
(find char #(#\tab #\space #\page)))
(defun setf-name-p (name)
(or (symbolp name)
(and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
(defgeneric specializer-name (specializer))
(defmethod specializer-name ((specializer eql-specializer))
(list 'eql (eql-specializer-object specializer)))
(defmethod specializer-name ((specializer class))
(class-name specializer))
(defun ensure-class-precedence-list (class)
(unless (class-finalized-p class)
(finalize-inheritance class))
(class-precedence-list class))
(defun specialized-lambda-list (method)
;; courtecy of AMOP p. 61
(let* ((specializers (method-specializers method))
(lambda-list (method-lambda-list method))
(n-required (length specializers)))
(append (mapcar (lambda (arg specializer)
(if (eq specializer (find-class 't))
arg
`(,arg ,(specializer-name specializer))))
(subseq lambda-list 0 n-required)
specializers)
(subseq lambda-list n-required))))
(defun string-lines (string)
"Lines in STRING as a vector."
(coerce (with-input-from-string (s string)
(loop for line = (read-line s nil nil)
while line collect line))
'vector))
(defun indentation (line)
"Position of first non-SPACE character in LINE."
(position-if-not (lambda (c) (char= c #\Space)) line))
(defun docstring (x doc-type)
(cl:documentation x doc-type))
(defun flatten-to-string (list)
(format nil "~{~A~^-~}" (flatten list)))
(defun alphanumize (original)
"Construct a string without characters like *`' that will f-star-ck
up filename handling. See `*character-replacements*' and
`*characters-to-drop*' for customization."
(let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
(if (listp original)
(flatten-to-string original)
(string original))))
(chars-to-replace (mapcar #'car *character-replacements*)))
(flet ((replacement-delimiter (index)
(cond ((or (< index 0) (>= index (length name))) "")
((alphanumericp (char name index)) "-")
(t ""))))
(loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
name)
while index
do (setf name (concatenate 'string (subseq name 0 index)
(replacement-delimiter (1- index))
(cdr (assoc (aref name index)
*character-replacements*))
(replacement-delimiter (1+ index))
(subseq name (1+ index))))))
name))
;;;; generating various names
(defgeneric name (thing)
(:documentation "Name for a documented thing. Names are either
symbols or lists of symbols."))
(defmethod name ((symbol symbol))
symbol)
(defmethod name ((cons cons))
cons)
(defmethod name ((package package))
(short-package-name package))
(defmethod name ((method method))
(list
(generic-function-name (method-generic-function method))
(method-qualifiers method)
(specialized-lambda-list method)))
;;; Node names for DOCUMENTATION instances
(defgeneric name-using-kind/name (kind name doc))
(defmethod name-using-kind/name (kind (name string) doc)
(declare (ignore kind doc))
name)
(defmethod name-using-kind/name (kind (name symbol) doc)
(declare (ignore kind))
(format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
(defmethod name-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
(format nil "~A~{ ~A~} ~A"
(name-using-kind/name nil (first name) doc)
(second name)
(third name)))
(defun node-name (doc)
"Returns TexInfo node name as a string for a DOCUMENTATION instance."
(let ((kind (get-kind doc)))
(format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
(defun short-package-name (package)
(unless (eq package *base-package*)
(car (sort (copy-list (cons (package-name package) (package-nicknames package)))
#'< :key #'length))))
;;; Definition titles for DOCUMENTATION instances
(defgeneric title-using-kind/name (kind name doc))
(defmethod title-using-kind/name (kind (name string) doc)
(declare (ignore kind doc))
name)
(defmethod title-using-kind/name (kind (name symbol) doc)
(declare (ignore kind))
(format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
(defmethod title-using-kind/name (kind (name list) doc)
(declare (ignore kind))
(assert (setf-name-p name))
(format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
(format nil "~{~A ~}~A"
(second name)
(title-using-kind/name nil (first name) doc)))
(defun title-name (doc)
"Returns a string to be used as name of the definition."
(string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
(defun include-pathname (doc)
(let* ((kind (get-kind doc))
(name (nstring-downcase
(if (eq 'package kind)
(format nil "package-~A" (alphanumize (get-name doc)))
(format nil "~A-~A-~A"
(case (get-kind doc)
((function generic-function) "fun")
(structure "struct")
(variable "var")
(otherwise (symbol-name (get-kind doc))))
(alphanumize (let ((*base-package* nil))
(short-package-name (get-package doc))))
(alphanumize (get-name doc)))))))
(make-pathname :name name :type "texinfo")))
;;;; documentation class and related methods
(defclass documentation ()
((name :initarg :name :reader get-name)
(kind :initarg :kind :reader get-kind)
(string :initarg :string :reader get-string)
(children :initarg :children :initform nil :reader get-children)
(package :initform *documentation-package* :reader get-package)))
(defmethod print-object ((documentation documentation) stream)
(print-unreadable-object (documentation stream :type t)
(princ (list (get-kind documentation) (get-name documentation)) stream)))
(defgeneric make-documentation (x doc-type string))
(defmethod make-documentation ((x package) doc-type string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'package
:string string))
(defmethod make-documentation (x (doc-type (eql 'function)) string)
(declare (ignore doc-type))
(let* ((fdef (and (fboundp x) (fdefinition x)))
(name x)
(kind (cond ((and (symbolp x) (special-operator-p x))
'special-operator)
((and (symbolp x) (macro-function x))
'macro)
((typep fdef 'generic-function)
(assert (or (symbolp name) (setf-name-p name)))
'generic-function)
(fdef
(assert (or (symbolp name) (setf-name-p name)))
'function)))
(children (when (eq kind 'generic-function)
(collect-gf-documentation fdef))))
(make-instance 'documentation
:name (name x)
:string string
:kind kind
:children children)))
(defmethod make-documentation ((x method) doc-type string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'method
:string string))
(defmethod make-documentation (x (doc-type (eql 'type)) string)
(make-instance 'documentation
:name (name x)
:string string
:kind (etypecase (find-class x nil)
(structure-class 'structure)
(standard-class 'class)
(sb-pcl::condition-class 'condition)
((or built-in-class null) 'type))))
(defmethod make-documentation (x (doc-type (eql 'variable)) string)
(make-instance 'documentation
:name (name x)
:string string
:kind (if (constantp x)
'constant
'variable)))
(defmethod make-documentation (x (doc-type (eql 'setf)) string)
(declare (ignore doc-type))
(make-instance 'documentation
:name (name x)
:kind 'setf-expander
:string string))
(defmethod make-documentation (x doc-type string)
(make-instance 'documentation
:name (name x)
:kind doc-type
:string string))
(defun maybe-documentation (x doc-type)
"Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
there is no corresponding docstring."
(let ((docstring (docstring x doc-type)))
(when docstring
(make-documentation x doc-type docstring))))
(defun lambda-list (doc)
(case (get-kind doc)
((package constant variable type structure class condition nil)
nil)
(method
(third (get-name doc)))
(t
;; KLUDGE: Eugh.
;;
;; believe it or not, the above comment was written before CSR
;; came along and obfuscated this. (2005-07-04)
(when (symbolp (get-name doc))
(labels ((clean (x &key optional key)
(typecase x
(atom x)
((cons (member &optional))
(cons (car x) (clean (cdr x) :optional t)))
((cons (member &key))
(cons (car x) (clean (cdr x) :key t)))
((cons (member &whole &environment))
;; Skip these
(clean (cdr x) :optional optional :key key))
((cons cons)
(cons
(cond (key (if (consp (caar x))
(caaar x)
(caar x)))
(optional (caar x))
(t (clean (car x))))
(clean (cdr x) :key key :optional optional)))
(cons
(cons
(cond ((or key optional) (car x))
(t (clean (car x))))
(clean (cdr x) :key key :optional optional))))))
(clean (sb-introspect:function-lambda-list (get-name doc))))))))
(defun get-string-name (x)
(let ((name (get-name x)))
(cond ((symbolp name)
(symbol-name name))
((and (consp name) (eq 'setf (car name)))
(symbol-name (second name)))
((stringp name)
name)
(t
(error "Don't know which symbol to use for name ~S" name)))))
(defun documentation< (x y)
(let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
(p2 (position (get-kind y) *ordered-documentation-kinds*)))
(if (or (not (and p1 p2)) (= p1 p2))
(string< (get-string-name x) (get-string-name y))
(< p1 p2))))
;;;; turning text into texinfo
(defun escape-for-texinfo (string &optional downcasep)
"Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
with #\@. Optionally downcase the result."
(let ((result (with-output-to-string (s)
(loop for char across string
when (find char *texinfo-escaped-chars*)
do (write-char #\@ s)
do (write-char char s)))))
(if downcasep (nstring-downcase result) result)))
(defun empty-p (line-number lines)
(and (< -1 line-number (length lines))
(not (indentation (svref lines line-number)))))
;;; line markups
(defvar *not-symbols* '("ANSI" "CLHS"))
(defun locate-symbols (line)
"Return a list of index pairs of symbol-like parts of LINE."
;; This would be a good application for a regex ...
(let (result)
(flet ((grab (start end)
(unless (member (subseq line start end) '("ANSI" "CLHS"))
(push (list start end) result))))
(do ((begin nil)
(maybe-begin t)
(i 0 (1+ i)))
((= i (length line))
;; symbol at end of line
(when (and begin (or (> i (1+ begin))
(not (member (char line begin) '(#\A #\I)))))
(grab begin i))
(nreverse result))
(cond
((and begin (find (char line i) *symbol-delimiters*))
;; symbol end; remember it if it's not "A" or "I"
(when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
(grab begin i))
(setf begin nil
maybe-begin t))
((and begin (not (find (char line i) *symbol-characters*)))
;; Not a symbol: abort
(setf begin nil))
((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
;; potential symbol begin at this position
(setf begin i
maybe-begin nil))
((find (char line i) *symbol-delimiters*)
;; potential symbol begin after this position
(setf maybe-begin t))
(t
;; Not reading a symbol, not at potential start of symbol
(setf maybe-begin nil)))))))
(defun texinfo-line (line)
"Format symbols in LINE texinfo-style: either as code or as
variables if the symbol in question is contained in symbols
*TEXINFO-VARIABLES*."
(with-output-to-string (result)
(let ((last 0))
(dolist (symbol/index (locate-symbols line))
(write-string (subseq line last (first symbol/index)) result)
(let ((symbol-name (apply #'subseq line symbol/index)))
(format result (if (member symbol-name *texinfo-variables*
:test #'string=)
"@var{~A}"
"@code{~A}")
(string-downcase symbol-name)))
(setf last (second symbol/index)))
(write-string (subseq line last) result))))
;;; lisp sections
(defun lisp-section-p (line line-number lines)
"Returns T if the given LINE looks like start of lisp code --
ie. if it starts with whitespace followed by a paren or
semicolon, and the previous line is empty"
(let ((offset (indentation line)))
(and offset
(plusp offset)
(find (find-if-not #'whitespacep line) "(;")
(empty-p (1- line-number) lines))))
(defun collect-lisp-section (lines line-number)
(let ((lisp (loop for index = line-number then (1+ index)
for line = (and (< index (length lines)) (svref lines index))
while (indentation line)
collect line)))
(values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
;;; itemized sections
(defun maybe-itemize-offset (line)
"Return NIL or the indentation offset if LINE looks like it starts
an item in an itemization."
(let* ((offset (indentation line))
(char (when offset (char line offset))))
(and offset
(member char *itemize-start-characters* :test #'char=)
(char= #\Space (find-if-not (lambda (c) (char= c char))
line :start offset))
offset)))
(defun collect-maybe-itemized-section (lines starting-line)
;; Return index of next line to be processed outside
(let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
(result nil)
(lines-consumed 0))
(loop for line-number from starting-line below (length lines)
for line = (svref lines line-number)
for indentation = (indentation line)
for offset = (maybe-itemize-offset line)
do (cond
((not indentation)
;; empty line -- inserts paragraph.
(push "" result)
(incf lines-consumed))
((and offset (> indentation this-offset))
;; nested itemization -- handle recursively
;; FIXME: tables in itemizations go wrong
(multiple-value-bind (sub-lines-consumed sub-itemization)
(collect-maybe-itemized-section lines line-number)
(when sub-lines-consumed
(incf line-number (1- sub-lines-consumed)) ; +1 on next loop
(incf lines-consumed sub-lines-consumed)
(setf result (nconc (nreverse sub-itemization) result)))))
((and offset (= indentation this-offset))
;; start of new item
(push (format nil "@item ~A"
(texinfo-line (subseq line (1+ offset))))
result)
(incf lines-consumed))
((and (not offset) (> indentation this-offset))
;; continued item from previous line
(push (texinfo-line line) result)
(incf lines-consumed))
(t
;; end of itemization
(loop-finish))))
;; a single-line itemization isn't.
(if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
(values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
nil)))
;;; table sections
(defun tabulation-body-p (offset line-number lines)
(when (< line-number (length lines))
(let ((offset2 (indentation (svref lines line-number))))
(and offset2 (< offset offset2)))))
(defun tabulation-p (offset line-number lines direction)
(let ((step (ecase direction
(:backwards (1- line-number))
(:forwards (1+ line-number)))))
(when (and (plusp line-number) (< line-number (length lines)))
(and (eql offset (indentation (svref lines line-number)))
(or (when (eq direction :backwards)
(empty-p step lines))
(tabulation-p offset step lines direction)
(tabulation-body-p offset step lines))))))
(defun maybe-table-offset (line-number lines)
"Return NIL or the indentation offset if LINE looks like it starts
an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
empty line, another tabulation label, or a tabulation body, (3) and
followed another tabulation label or a tabulation body."
(let* ((line (svref lines line-number))
(offset (indentation line))
(prev (1- line-number))
(next (1+ line-number)))
(when (and offset (plusp offset))
(and (or (empty-p prev lines)
(tabulation-body-p offset prev lines)
(tabulation-p offset prev lines :backwards))
(or (tabulation-body-p offset next lines)
(tabulation-p offset next lines :forwards))
offset))))
;;; FIXME: This and itemization are very similar: could they share
;;; some code, mayhap?
(defun collect-maybe-table-section (lines starting-line)
;; Return index of next line to be processed outside
(let ((this-offset (maybe-table-offset starting-line lines))
(result nil)
(lines-consumed 0))
(loop for line-number from starting-line below (length lines)
for line = (svref lines line-number)
for indentation = (indentation line)
for offset = (maybe-table-offset line-number lines)
do (cond
((not indentation)
;; empty line -- inserts paragraph.
(push "" result)
(incf lines-consumed))
((and offset (= indentation this-offset))
;; start of new item, or continuation of previous item
(if (and result (search "@item" (car result) :test #'char=))
(push (format nil "@itemx ~A" (texinfo-line line))
result)
(progn
(push "" result)
(push (format nil "@item ~A" (texinfo-line line))
result)))
(incf lines-consumed))
((> indentation this-offset)
;; continued item from previous line
(push (texinfo-line line) result)
(incf lines-consumed))
(t
;; end of itemization
(loop-finish))))
;; a single-line table isn't.
(if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
(values lines-consumed
`("" "@table @emph" ,@(reverse result) "@end table" ""))
nil)))
;;; section markup
(defmacro with-maybe-section (index &rest forms)
`(multiple-value-bind (count collected) (progn ,@forms)
(when count
(dolist (line collected)
(write-line line *texinfo-output*))
(incf ,index (1- count)))))
(defun write-texinfo-string (string &optional lambda-list)
"Try to guess as much formatting for a raw docstring as possible."
(let ((*texinfo-variables* (flatten lambda-list))
(lines (string-lines (escape-for-texinfo string nil))))
(loop for line-number from 0 below (length lines)
for line = (svref lines line-number)
do (cond
((with-maybe-section line-number
(and (lisp-section-p line line-number lines)
(collect-lisp-section lines line-number))))
((with-maybe-section line-number
(and (maybe-itemize-offset line)
(collect-maybe-itemized-section lines line-number))))
((with-maybe-section line-number
(and (maybe-table-offset line-number lines)
(collect-maybe-table-section lines line-number))))
(t
(write-line (texinfo-line line) *texinfo-output*))))))
;;;; texinfo formatting tools
(defun hide-superclass-p (class-name super-name)
(let ((super-package (symbol-package super-name)))
(or
;; KLUDGE: We assume that we don't want to advertise internal
;; classes in CP-lists, unless the symbol we're documenting is
;; internal as well.
(and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
(not (eq super-package (symbol-package class-name))))
;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
;; simply as a matter of convenience. The assumption here is that
;; the inheritance is incidental unless the name of the condition
;; begins with SIMPLE-.
(and (member super-name '(simple-error simple-condition))
(let ((prefix "SIMPLE-"))
(mismatch prefix (string class-name) :end2 (length prefix)))
t ; don't return number from MISMATCH
))))
(defun hide-slot-p (symbol slot)
;; FIXME: There is no pricipal reason to avoid the slot docs fo
;; structures and conditions, but their DOCUMENTATION T doesn't
;; currently work with them the way we'd like.
(not (and (typep (find-class symbol nil) 'standard-class)
(docstring slot t))))
(defun texinfo-anchor (doc)
(format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
(defun texinfo-begin (doc &aux *print-pretty*)
(let ((kind (get-kind doc)))
(format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
(case kind
((package constant variable)
"defvr")
((structure class condition type)
"deftp")
(t
"deffn"))
(map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
(title-name doc)
;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
;; interactions,so we escape the ampersand -- amusingly for TeX.
;; sbcl.texinfo defines macros that expand @&key and friends to &key.
(mapcar (lambda (name)
(if (member name lambda-list-keywords)
(format nil "@~A" name)
name))
(lambda-list doc)))))
(defun texinfo-index (doc)
(let ((title (title-name doc)))
(case (get-kind doc)
((structure type class condition)
(format *texinfo-output* "@tindex ~A~%" title))
((variable constant)
(format *texinfo-output* "@vindex ~A~%" title))
((compiler-macro function method-combination macro generic-function)
(format *texinfo-output* "@findex ~A~%" title)))))
(defun texinfo-inferred-body (doc)
(when (member (get-kind doc) '(class structure condition))
(let ((name (get-name doc)))
;; class precedence list
(format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
(remove-if (lambda (class) (hide-superclass-p name class))
(mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
;; slots
(let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
(class-direct-slots (find-class name)))))
(when slots
(format *texinfo-output* "Slots:~%@itemize~%")
(dolist (slot slots)
(format *texinfo-output*
"@item ~(@code{~A}~#[~:; --- ~]~
~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
(slot-definition-name slot)
(remove
nil
(mapcar
(lambda (name things)
(if things
(list name (length things) things)))
'("initarg" "reader" "writer")
(list
(slot-definition-initargs slot)
(slot-definition-readers slot)
(slot-definition-writers slot)))))
;; FIXME: Would be neater to handler as children
(write-texinfo-string (docstring slot t)))
(format *texinfo-output* "@end itemize~%~%"))))))
(defun texinfo-body (doc)
(write-texinfo-string (get-string doc)))
(defun texinfo-end (doc)
(write-line (case (get-kind doc)
((package variable constant) "@end defvr")
((structure type class condition) "@end deftp")
(t "@end deffn"))
*texinfo-output*))
(defun write-texinfo (doc)
"Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
(texinfo-anchor doc)
(texinfo-begin doc)
(texinfo-index doc)
(texinfo-inferred-body doc)
(texinfo-body doc)
(texinfo-end doc)
;; FIXME: Children should be sorted one way or another
(mapc #'write-texinfo (get-children doc)))
;;;; main logic
(defun collect-gf-documentation (gf)
"Collects method documentation for the generic function GF"
(loop for method in (generic-function-methods gf)
for doc = (maybe-documentation method t)
when doc
collect doc))
(defun collect-name-documentation (name)
(loop for type in *documentation-types*
for doc = (maybe-documentation name type)
when doc
collect doc))
(defun collect-symbol-documentation (symbol)
"Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
the form DOC instances. See `*documentation-types*' for the possible
values of doc-type."
(nconc (collect-name-documentation symbol)
(collect-name-documentation (list 'setf symbol))))
(defun collect-documentation (package)
"Collects all documentation for all external symbols of the given
package, as well as for the package itself."
(let* ((*documentation-package* (find-package package))
(docs nil))
(check-type package package)
(do-external-symbols (symbol package)
(setf docs (nconc (collect-symbol-documentation symbol) docs)))
(let ((doc (maybe-documentation *documentation-package* t)))
(when doc
(push doc docs)))
docs))
(defmacro with-texinfo-file (pathname &body forms)
`(with-open-file (*texinfo-output* ,pathname
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
,@forms))
(defun write-ifnottex ()
;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
;; define them for info as well.
(flet ((macro (name)
(let ((string (string-downcase name)))
(format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
(macro '&allow-other-keys)
(macro '&optional)
(macro '&rest)
(macro '&key)
(macro '&body)))
(defun generate-includes (directory packages &key (base-package :cl-user))
"Create files in `directory' containing Texinfo markup of all
docstrings of each exported symbol in `packages'. `directory' is
created if necessary. If you supply a namestring that doesn't end in a
slash, you lose. The generated files are of the form
\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
via @include statements. Texinfo syntax-significant characters are
escaped in symbol names, but if a docstring contains invalid Texinfo
markup, you lose."
(handler-bind ((warning #'muffle-warning))
(let ((directory (merge-pathnames (pathname directory)))
(*base-package* (find-package base-package)))
(ensure-directories-exist directory)
(dolist (package packages)
(dolist (doc (collect-documentation (find-package package)))
(with-texinfo-file (merge-pathnames (include-pathname doc) directory)
(write-texinfo doc))))
(with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
(write-ifnottex))
directory)))
(defun document-package (package &optional filename)
"Create a file containing all available documentation for the
exported symbols of `package' in Texinfo format. If `filename' is not
supplied, a file \"<packagename>.texinfo\" is generated.
The definitions can be referenced using Texinfo statements like
@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
syntax-significant characters are escaped in symbol names, but if a
docstring contains invalid Texinfo markup, you lose."
(handler-bind ((warning #'muffle-warning))
(let* ((package (find-package package))
(filename (or filename (make-pathname
:name (string-downcase (short-package-name package))
:type "texinfo")))
(docs (sort (collect-documentation package) #'documentation<)))
(with-texinfo-file filename
(dolist (doc docs)
(write-texinfo doc)))
filename)))

14
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/features.lisp Normal file
View file

@ -0,0 +1,14 @@
(in-package :alexandria)
(defun featurep (feature-expression)
"Returns T if the argument matches the state of the *FEATURES*
list and NIL if it does not. FEATURE-EXPRESSION can be any atom
or list acceptable to the reader macros #+ and #-."
(etypecase feature-expression
(symbol (not (null (member feature-expression *features*))))
(cons (check-type (first feature-expression) symbol)
(eswitch ((first feature-expression) :test 'string=)
(:and (every #'featurep (rest feature-expression)))
(:or (some #'featurep (rest feature-expression)))
(:not (assert (= 2 (length feature-expression)))
(not (featurep (second feature-expression))))))))

161
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/functions.lisp Normal file
View file

@ -0,0 +1,161 @@
(in-package :alexandria)
;;; To propagate return type and allow the compiler to eliminate the IF when
;;; it is known if the argument is function or not.
(declaim (inline ensure-function))
(declaim (ftype (function (t) (values function &optional))
ensure-function))
(defun ensure-function (function-designator)
"Returns the function designated by FUNCTION-DESIGNATOR:
if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
it must be a function name and its FDEFINITION is returned."
(if (functionp function-designator)
function-designator
(fdefinition function-designator)))
(define-modify-macro ensure-functionf/1 () ensure-function)
(defmacro ensure-functionf (&rest places)
"Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
PLACES contains a function."
`(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
(defun disjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning the primary value of the first
predicate that returns true, without calling the remaining predicates.
If none of the predicates returns true, NIL is returned."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(let ((predicate (ensure-function predicate))
(more-predicates (mapcar #'ensure-function more-predicates)))
(lambda (&rest arguments)
(or (apply predicate arguments)
(some (lambda (p)
(declare (type function p))
(apply p arguments))
more-predicates)))))
(defun conjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning NIL if any of the predicates
returns false, without calling the remaining predicates. If none of the
predicates returns false, returns the primary value of the last predicate."
(if (null more-predicates)
predicate
(lambda (&rest arguments)
(and (apply predicate arguments)
;; Cannot simply use CL:EVERY because we want to return the
;; non-NIL value of the last predicate if all succeed.
(do ((tail (cdr more-predicates) (cdr tail))
(head (car more-predicates) (car tail)))
((not tail)
(apply head arguments))
(unless (apply head arguments)
(return nil)))))))
(defun compose (function &rest more-functions)
"Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
and then calling the next one with the primary value of the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(funcall f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(funcall ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "COMPOSE")))
`(let ,(loop for f in funs for arg in args
collect `(,f (ensure-function ,arg)))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(defun multiple-value-compose (function &rest more-functions)
"Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
its arguments to each in turn, starting from the rightmost of
MORE-FUNCTIONS, and then calling the next one with all the return values of
the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(multiple-value-call f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro multiple-value-compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "MV-COMPOSE")))
`(let ,(mapcar #'list funs args)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(declaim (inline curry rcurry))
(defun curry (function &rest arguments)
"Returns a function that applies ARGUMENTS and the arguments
it is called with to FUNCTION."
(declare (optimize (speed 3) (safety 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
;; Using M-V-C we don't need to append the arguments.
(multiple-value-call fn (values-list arguments) (values-list more)))))
(define-compiler-macro curry (function &rest arguments)
(let ((curries (make-gensym-list (length arguments) "CURRY"))
(fun (gensym "FUN")))
`(let ((,fun (ensure-function ,function))
,@(mapcar #'list curries arguments))
(declare (optimize (speed 3) (safety 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(apply ,fun ,@curries more)))))
(defun rcurry (function &rest arguments)
"Returns a function that applies the arguments it is called
with and ARGUMENTS to FUNCTION."
(declare (optimize (speed 3) (safety 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call fn (values-list more) (values-list arguments)))))
(define-compiler-macro rcurry (function &rest arguments)
(let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
(fun (gensym "FUN")))
`(let ((,fun (ensure-function ,function))
,@(mapcar #'list rcurries arguments))
(declare (optimize (speed 3) (safety 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call ,fun (values-list more) ,@rcurries)))))
(declaim (notinline curry rcurry))
(defmacro named-lambda (name lambda-list &body body)
"Expands into a lambda-expression within whose BODY NAME denotes the
corresponding function."
`(labels ((,name ,lambda-list ,@body))
#',name))

101
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/hash-tables.lisp Normal file
View file

@ -0,0 +1,101 @@
(in-package :alexandria)
(defmacro ensure-gethash (key hash-table &optional default)
"Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
under key before returning it. Secondary return value is true if key was
already in the table."
(once-only (key hash-table)
(with-unique-names (value presentp)
`(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
(if ,presentp
(values ,value ,presentp)
(values (setf (gethash ,key ,hash-table) ,default) nil))))))
(defun copy-hash-table (table &key key test size
rehash-size rehash-threshold)
"Returns a copy of hash table TABLE, with the same keys and values
as the TABLE. The copy has the same properties as the original, unless
overridden by the keyword arguments.
Before each of the original values is set into the new hash-table, KEY
is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
copy is returned by default."
(setf key (or key 'identity))
(setf test (or test (hash-table-test table)))
(setf size (or size (hash-table-size table)))
(setf rehash-size (or rehash-size (hash-table-rehash-size table)))
(setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
(let ((copy (make-hash-table :test test :size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(maphash (lambda (k v)
(setf (gethash k copy) (funcall key v)))
table)
copy))
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
(maphash (lambda (k v)
(declare (ignore v))
(funcall function k))
table))
(declaim (inline maphash-values))
(defun maphash-values (function table)
"Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
(maphash (lambda (k v)
(declare (ignore k))
(funcall function v))
table))
(defun hash-table-keys (table)
"Returns a list containing the keys of hash table TABLE."
(let ((keys nil))
(maphash-keys (lambda (k)
(push k keys))
table)
keys))
(defun hash-table-values (table)
"Returns a list containing the values of hash table TABLE."
(let ((values nil))
(maphash-values (lambda (v)
(push v values))
table)
values))
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
TABLE."
(let ((alist nil))
(maphash (lambda (k v)
(push (cons k v) alist))
table)
alist))
(defun hash-table-plist (table)
"Returns a property list containing the keys and values of hash table
TABLE."
(let ((plist nil))
(maphash (lambda (k v)
(setf plist (list* k v plist)))
table)
plist))
(defun alist-hash-table (alist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the association list
ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(dolist (cons alist)
(ensure-gethash (car cons) table (cdr cons)))
table))
(defun plist-hash-table (plist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the property list
PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(do ((tail plist (cddr tail)))
((not tail))
(ensure-gethash (car tail) table (cadr tail)))
table))

172
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/io.lisp Normal file
View file

@ -0,0 +1,172 @@
;; Copyright (c) 2002-2006, Edward Marco Baringer
;; All rights reserved.
(in-package :alexandria)
(defmacro with-open-file* ((stream filespec &key direction element-type
if-exists if-does-not-exist external-format)
&body body)
"Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
the default value specified for OPEN."
(once-only (direction element-type if-exists if-does-not-exist external-format)
`(with-open-stream
(,stream (apply #'open ,filespec
(append
(when ,direction
(list :direction ,direction))
(when ,element-type
(list :element-type ,element-type))
(when ,if-exists
(list :if-exists ,if-exists))
(when ,if-does-not-exist
(list :if-does-not-exist ,if-does-not-exist))
(when ,external-format
(list :external-format ,external-format)))))
,@body)))
(defmacro with-input-from-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
&body body)
"Evaluate BODY with STREAM-NAME to an input stream on the file
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :input ,@args)
,@body))
(defmacro with-output-to-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
&body body)
"Evaluate BODY with STREAM-NAME to an output stream on the file
FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
which is only sent to WITH-OPEN-FILE when it's not NIL."
(declare (ignore direction))
(when direction-p
(error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
,@body))
(defun read-stream-content-into-string (stream &key (buffer-size 4096))
"Return the \"content\" of STREAM as a fresh string."
(check-type buffer-size positive-integer)
(let ((*print-pretty* nil))
(with-output-to-string (datum)
(let ((buffer (make-array buffer-size :element-type 'character)))
(loop
:for bytes-read = (read-sequence buffer stream)
:do (write-sequence buffer datum :start 0 :end bytes-read)
:while (= bytes-read buffer-size))))))
(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
"Return the contents of the file denoted by PATHNAME as a fresh string.
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
unless it's NIL, which means the system default."
(with-input-from-file
(file-stream pathname :external-format external-format)
(read-stream-content-into-string file-stream :buffer-size buffer-size)))
(defun write-string-into-file (string pathname &key (if-exists :error)
if-does-not-exist
external-format)
"Write STRING to PATHNAME.
The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
unless it's NIL, which means the system default."
(with-output-to-file (file-stream pathname :if-exists if-exists
:if-does-not-exist if-does-not-exist
:external-format external-format)
(write-sequence string file-stream)))
(defun read-stream-content-into-byte-vector (stream &key ((%length length))
(initial-size 4096))
"Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
(check-type length (or null non-negative-integer))
(check-type initial-size positive-integer)
(do ((buffer (make-array (or length initial-size)
:element-type '(unsigned-byte 8)))
(offset 0)
(offset-wanted 0))
((or (/= offset-wanted offset)
(and length (>= offset length)))
(if (= offset (length buffer))
buffer
(subseq buffer 0 offset)))
(unless (zerop offset)
(let ((new-buffer (make-array (* 2 (length buffer))
:element-type '(unsigned-byte 8))))
(replace new-buffer buffer)
(setf buffer new-buffer)))
(setf offset-wanted (length buffer)
offset (read-sequence buffer stream :start offset))))
(defun read-file-into-byte-vector (pathname)
"Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
(with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
(read-stream-content-into-byte-vector stream '%length (file-length stream))))
(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
if-does-not-exist)
"Write BYTES to PATHNAME."
(check-type bytes (vector (unsigned-byte 8)))
(with-output-to-file (stream pathname :if-exists if-exists
:if-does-not-exist if-does-not-exist
:element-type '(unsigned-byte 8))
(write-sequence bytes stream)))
(defun copy-file (from to &key (if-to-exists :supersede)
(element-type '(unsigned-byte 8)) finish-output)
(with-input-from-file (input from :element-type element-type)
(with-output-to-file (output to :element-type element-type
:if-exists if-to-exists)
(copy-stream input output
:element-type element-type
:finish-output finish-output))))
(defun copy-stream (input output &key (element-type (stream-element-type input))
(buffer-size 4096)
(buffer (make-array buffer-size :element-type element-type))
(start 0) end
finish-output)
"Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
compatible element-types."
(check-type start non-negative-integer)
(check-type end (or null non-negative-integer))
(check-type buffer-size positive-integer)
(when (and end
(< end start))
(error "END is smaller than START in ~S" 'copy-stream))
(let ((output-position 0)
(input-position 0))
(unless (zerop start)
;; FIXME add platform specific optimization to skip seekable streams
(loop while (< input-position start)
do (let ((n (read-sequence buffer input
:end (min (length buffer)
(- start input-position)))))
(when (zerop n)
(error "~@<Could not read enough bytes from the input to fulfill ~
the :START ~S requirement in ~S.~:@>" 'copy-stream start))
(incf input-position n))))
(assert (= input-position start))
(loop while (or (null end) (< input-position end))
do (let ((n (read-sequence buffer input
:end (when end
(min (length buffer)
(- end input-position))))))
(when (zerop n)
(if end
(error "~@<Could not read enough bytes from the input to fulfill ~
the :END ~S requirement in ~S.~:@>" 'copy-stream end)
(return)))
(incf input-position n)
(write-sequence buffer output :end n)
(incf output-position n)))
(when finish-output
(finish-output output))
output-position))

367
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/lists.lisp Normal file
View file

@ -0,0 +1,367 @@
(in-package :alexandria)
(declaim (inline safe-endp))
(defun safe-endp (x)
(declare (optimize safety))
(endp x))
(defun alist-plist (alist)
"Returns a property list containing the same keys and values as the
association list ALIST in the same order."
(let (plist)
(dolist (pair alist)
(push (car pair) plist)
(push (cdr pair) plist))
(nreverse plist)))
(defun plist-alist (plist)
"Returns an association list containing the same keys and values as the
property list PLIST in the same order."
(let (alist)
(do ((tail plist (cddr tail)))
((safe-endp tail) (nreverse alist))
(push (cons (car tail) (cadr tail)) alist))))
(declaim (inline racons))
(defun racons (key value ralist)
(acons value key ralist))
(macrolet
((define-alist-get (name get-entry get-value-from-entry add doc)
`(progn
(declaim (inline ,name))
(defun ,name (alist key &key (test 'eql))
,doc
(let ((entry (,get-entry key alist :test test)))
(values (,get-value-from-entry entry) entry)))
(define-setf-expander ,name (place key &key (test ''eql)
&environment env)
(multiple-value-bind
(temporary-variables initforms newvals setter getter)
(get-setf-expansion place env)
(when (cdr newvals)
(error "~A cannot store multiple values in one place" ',name))
(with-unique-names (new-value key-val test-val alist entry)
(values
(append temporary-variables
(list alist
key-val
test-val
entry))
(append initforms
(list getter
key
test
`(,',get-entry ,key-val ,alist :test ,test-val)))
`(,new-value)
`(cond
(,entry
(setf (,',get-value-from-entry ,entry) ,new-value))
(t
(let ,newvals
(setf ,(first newvals) (,',add ,key ,new-value ,alist))
,setter
,new-value)))
`(,',get-value-from-entry ,entry))))))))
(define-alist-get assoc-value assoc cdr acons
"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
be used with SETF.")
(define-alist-get rassoc-value rassoc car racons
"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
be used with SETF."))
(defun malformed-plist (plist)
(error "Malformed plist: ~S" plist))
(defmacro doplist ((key val plist &optional values) &body body)
"Iterates over elements of PLIST. BODY can be preceded by
declarations, and is like a TAGBODY. RETURN may be used to terminate
the iteration early. If RETURN is not used, returns VALUES."
(multiple-value-bind (forms declarations) (parse-body body)
(with-gensyms (tail loop results)
`(block nil
(flet ((,results ()
(let (,key ,val)
(declare (ignorable ,key ,val))
(return ,values))))
(let* ((,tail ,plist)
(,key (if ,tail
(pop ,tail)
(,results)))
(,val (if ,tail
(pop ,tail)
(malformed-plist ',plist))))
(declare (ignorable ,key ,val))
,@declarations
(tagbody
,loop
,@forms
(setf ,key (if ,tail
(pop ,tail)
(,results))
,val (if ,tail
(pop ,tail)
(malformed-plist ',plist)))
(go ,loop))))))))
(define-modify-macro appendf (&rest lists) append
"Modify-macro for APPEND. Appends LISTS to the place designated by the first
argument.")
(define-modify-macro nconcf (&rest lists) nconc
"Modify-macro for NCONC. Concatenates LISTS to place designated by the first
argument.")
(define-modify-macro unionf (list &rest args) union
"Modify-macro for UNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place.")
(define-modify-macro nunionf (list &rest args) nunion
"Modify-macro for NUNION. Saves the union of LIST and the contents of the
place designated by the first argument to the designated place. May modify
either argument.")
(define-modify-macro reversef () reverse
"Modify-macro for REVERSE. Copies and reverses the list stored in the given
place and saves back the result into the place.")
(define-modify-macro nreversef () nreverse
"Modify-macro for NREVERSE. Reverses the list stored in the given place by
destructively modifying it and saves back the result into the place.")
(defun circular-list (&rest elements)
"Creates a circular list of ELEMENTS."
(let ((cycle (copy-list elements)))
(nconc cycle cycle)))
(defun circular-list-p (object)
"Returns true if OBJECT is a circular list, NIL otherwise."
(and (listp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (consp fast) (listp (cdr fast)))
(return nil))
(when (eq fast slow)
(return t)))))
(defun circular-tree-p (object)
"Returns true if OBJECT is a circular tree, NIL otherwise."
(labels ((circularp (object seen)
(and (consp object)
(do ((fast (cons (car object) (cdr object)) (cddr fast))
(slow object (cdr slow)))
(nil)
(when (or (eq fast slow) (member slow seen))
(return-from circular-tree-p t))
(when (or (not (consp fast)) (not (consp (cdr slow))))
(return
(do ((tail object (cdr tail)))
((not (consp tail))
nil)
(let ((elt (car tail)))
(circularp elt (cons object seen))))))))))
(circularp object nil)))
(defun proper-list-p (object)
"Returns true if OBJECT is a proper list."
(cond ((not object)
t)
((consp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (listp fast) (consp (cdr fast)))
(return (and (listp fast) (not (cdr fast)))))
(when (eq fast slow)
(return nil))))
(t
nil)))
(deftype proper-list ()
"Type designator for proper lists. Implemented as a SATISFIES type, hence
not recommended for performance intensive use. Main usefullness as a type
designator of the expected type in a TYPE-ERROR."
`(and list (satisfies proper-list-p)))
(defun circular-list-error (list)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))
(macrolet ((def (name lambda-list doc step declare ret1 ret2)
(assert (member 'list lambda-list))
`(defun ,name ,lambda-list
,doc
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow))
,@(when step (list step)))
(nil)
(declare (dynamic-extent slow) ,@(when declare (list declare))
(ignorable last))
(when (safe-endp fast)
(return ,ret1))
(when (safe-endp (cdr fast))
(return ,ret2))
(when (eq fast slow)
(circular-list-error list))))))
(def proper-list-length (list)
"Returns length of LIST, signalling an error if it is not a proper list."
(n 1 (+ n 2))
;; KLUDGE: Most implementations don't actually support lists with bignum
;; elements -- and this is WAY faster on most implementations then declaring
;; N to be an UNSIGNED-BYTE.
(fixnum n)
(1- n)
n)
(def lastcar (list)
"Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
nil
nil
(cadr last)
(car fast))
(def (setf lastcar) (object list)
"Sets the last element of LIST. Signals a type-error if LIST is not a proper
list."
nil
nil
(setf (cadr last) object)
(setf (car fast) object)))
(defun make-circular-list (length &key initial-element)
"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
(let ((cycle (make-list length :initial-element initial-element)))
(nconc cycle cycle)))
(deftype circular-list ()
"Type designator for circular lists. Implemented as a SATISFIES type, so not
recommended for performance intensive use. Main usefullness as the
expected-type designator of a TYPE-ERROR."
`(satisfies circular-list-p))
(defun ensure-car (thing)
"If THING is a CONS, its CAR is returned. Otherwise THING is returned."
(if (consp thing)
(car thing)
thing))
(defun ensure-cons (cons)
"If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
in the car, and NIL in the cdr."
(if (consp cons)
cons
(cons cons nil)))
(defun ensure-list (list)
"If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
(if (listp list)
list
(list list)))
(defun remove-from-plist (plist &rest keys)
"Returns a propery-list with same keys and values as PLIST, except that keys
in the list designated by KEYS and values corresponding to them are removed.
The returned property-list may share structure with the PLIST, but PLIST is
not destructively modified. Keys are compared using EQ."
(declare (optimize (speed 3)))
;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
;; could return the tail without consing up a new list.
(loop for (key . rest) on plist by #'cddr
do (assert rest () "Expected a proper plist, got ~S" plist)
unless (member key keys :test #'eq)
collect key and collect (first rest)))
(defun delete-from-plist (plist &rest keys)
"Just like REMOVE-FROM-PLIST, but this version may destructively modify the
provided PLIST."
(declare (optimize speed))
(loop with head = plist
with tail = nil ; a nil tail means an empty result so far
for (key . rest) on plist by #'cddr
do (assert rest () "Expected a proper plist, got ~S" plist)
(if (member key keys :test #'eq)
;; skip over this pair
(let ((next (cdr rest)))
(if tail
(setf (cdr tail) next)
(setf head next)))
;; keep this pair
(setf tail rest))
finally (return head)))
(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
"Modify macro for REMOVE-FROM-PLIST.")
(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
"Modify macro for DELETE-FROM-PLIST.")
(declaim (inline sans))
(defun sans (plist &rest keys)
"Alias of REMOVE-FROM-PLIST for backward compatibility."
(apply #'remove-from-plist plist keys))
(defun mappend (function &rest lists)
"Applies FUNCTION to respective element(s) of each LIST, appending all the
all the result list to a single list. FUNCTION must return a list."
(loop for results in (apply #'mapcar function lists)
append results))
(defun setp (object &key (test #'eql) (key #'identity))
"Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
denotes a set if each element of the list is unique under KEY and TEST."
(and (listp object)
(let (seen)
(dolist (elt object t)
(let ((key (funcall key elt)))
(if (member key seen :test test)
(return nil)
(push key seen)))))))
(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
"Returns true if every element of LIST1 matches some element of LIST2 and
every element of LIST2 matches some element of LIST1. Otherwise returns false."
(let ((keylist1 (if keyp (mapcar key list1) list1))
(keylist2 (if keyp (mapcar key list2) list2)))
(and (dolist (elt keylist1 t)
(or (member elt keylist2 :test test)
(return nil)))
(dolist (elt keylist2 t)
(or (member elt keylist1 :test test)
(return nil))))))
(defun map-product (function list &rest more-lists)
"Returns a list containing the results of calling FUNCTION with one argument
from LIST, and one from each of MORE-LISTS for each combination of arguments.
In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
Example:
(map-product 'list '(1 2) '(3 4) '(5 6))
=> ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
(2 3 5) (2 3 6) (2 4 5) (2 4 6))
"
(labels ((%map-product (f lists)
(let ((more (cdr lists))
(one (car lists)))
(if (not more)
(mapcar f one)
(mappend (lambda (x)
(%map-product (curry f x) more))
one)))))
(%map-product (ensure-function function) (cons list more-lists))))
(defun flatten (tree)
"Traverses the tree in order, collecting non-null leaves into a list."
(let (list)
(labels ((traverse (subtree)
(when subtree
(if (consp subtree)
(progn
(traverse (car subtree))
(traverse (cdr subtree)))
(push subtree list)))))
(traverse tree))
(nreverse list)))

370
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/macros.lisp Normal file
View file

@ -0,0 +1,370 @@
(in-package :alexandria)
(defmacro with-gensyms (names &body forms)
"Binds a set of variables to gensyms and evaluates the implicit progn FORMS.
Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL
STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
should be bound to a symbol constructed using GENSYM with the string designated
by STRING-DESIGNATOR being its first argument."
`(let ,(mapcar (lambda (name)
(multiple-value-bind (symbol string)
(etypecase name
(symbol
(values name (symbol-name name)))
((cons symbol (cons string-designator null))
(values (first name) (string (second name)))))
`(,symbol (gensym ,string))))
names)
,@forms))
(defmacro with-unique-names (names &body forms)
"Alias for WITH-GENSYMS."
`(with-gensyms ,names ,@forms))
(defmacro once-only (specs &body forms)
"Constructs code whose primary goal is to help automate the handling of
multiple evaluation within macros. Multiple evaluation is handled by introducing
intermediate variables, in order to reuse the result of an expression.
The returned value is a list of the form
(let ((<gensym-1> <expr-1>)
...
(<gensym-n> <expr-n>))
<res>)
where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
evaluating the implicit progn FORMS within a special context determined by
SPECS. RES should make use of (reference) the intermediate variables.
Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
- INITFORM is an expression evaluated to produce EXPR-i
- SYMBOL is the name of the variable that will be bound around FORMS to the
corresponding gensym GENSYM-i, in order for FORMS to generate RES that
references the intermediate variable
The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
Example:
The following expression
(let ((x '(incf y)))
(once-only (x)
`(cons ,x ,x)))
;;; =>
;;; (let ((#1=#:X123 (incf y)))
;;; (cons #1# #1#))
could be used within a macro to avoid multiple evaluation like so
(defmacro cons1 (x)
(once-only (x)
`(cons ,x ,x)))
(let ((y 0))
(cons1 (incf y)))
;;; => (1 . 1)
Example:
The following expression demonstrates the usage of the INITFORM field
(let ((expr '(incf y)))
(once-only ((var `(1+ ,expr)))
`(list ',expr ,var ,var)))
;;; =>
;;; (let ((#1=#:VAR123 (1+ (incf y))))
;;; (list '(incf y) #1# #1))
which could be used like so
(defmacro print-succ-twice (expr)
(once-only ((var `(1+ ,expr)))
`(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
(let ((y 10))
(print-succ-twice (incf y)))
;;; >>
;;; Expr: (INCF Y), Once: 12, Twice: 12"
(let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
(names-and-forms (mapcar (lambda (spec)
(etypecase spec
(list
(destructuring-bind (name form) spec
(cons name form)))
(symbol
(cons spec spec))))
specs)))
;; bind in user-macro
`(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
gensyms names-and-forms)
;; bind in final expansion
`(let (,,@(mapcar (lambda (g n)
``(,,g ,,(cdr n)))
gensyms names-and-forms))
;; bind in user-macro
,(let ,(mapcar (lambda (n g) (list (car n) g))
names-and-forms gensyms)
,@forms)))))
(defun parse-body (body &key documentation whole)
"Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given."
(let ((doc nil)
(decls nil)
(current nil))
(tagbody
:declarations
(setf current (car body))
(when (and documentation (stringp current) (cdr body))
(if doc
(error "Too many documentation strings in ~S." (or whole body))
(setf doc (pop body)))
(go :declarations))
(when (and (listp current) (eql (first current) 'declare))
(push (pop body) decls)
(go :declarations)))
(values body (nreverse decls) doc)))
(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
allow-specializers
(normalize-optional normalize)
(normalize-keyword normalize)
(normalize-auxilary normalize))
"Parses an ordinary lambda-list, returning as multiple values:
1. Required parameters.
2. Optional parameter specifications, normalized into form:
(name init suppliedp)
3. Name of the rest parameter, or NIL.
4. Keyword parameter specifications, normalized into form:
((keyword-name name) init suppliedp)
5. Boolean indicating &ALLOW-OTHER-KEYS presence.
6. &AUX parameter specifications, normalized into form
(name init).
7. Existence of &KEY in the lambda-list.
Signals a PROGRAM-ERROR is the lambda-list is malformed."
(let ((state :required)
(allow-other-keys nil)
(auxp nil)
(required nil)
(optional nil)
(rest nil)
(keys nil)
(keyp nil)
(aux nil))
(labels ((fail (elt)
(simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(check-variable (elt what &optional (allow-specializers allow-specializers))
(unless (and (or (symbolp elt)
(and allow-specializers
(consp elt) (= 2 (length elt)) (symbolp (first elt))))
(not (constantp elt)))
(simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
what elt lambda-list)))
(check-spec (spec what)
(destructuring-bind (init suppliedp) spec
(declare (ignore init))
(check-variable suppliedp what nil))))
(dolist (elt lambda-list)
(case elt
(&optional
(if (eq state :required)
(setf state elt)
(fail elt)))
(&rest
(if (member state '(:required &optional))
(setf state elt)
(fail elt)))
(&key
(if (member state '(:required &optional :after-rest))
(setf state elt)
(fail elt))
(setf keyp t))
(&allow-other-keys
(if (eq state '&key)
(setf allow-other-keys t
state elt)
(fail elt)))
(&aux
(cond ((eq state '&rest)
(fail elt))
(auxp
(simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(t
(setf auxp t
state elt))
))
(otherwise
(when (member elt '#.(set-difference lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux)))
(simple-program-error
"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(case state
(:required
(check-variable elt "required parameter")
(push elt required))
(&optional
(cond ((consp elt)
(destructuring-bind (name &rest tail) elt
(check-variable name "optional parameter")
(cond ((cdr tail)
(check-spec tail "optional-supplied-p parameter"))
((and normalize-optional tail)
(setf elt (append elt '(nil))))
(normalize-optional
(setf elt (append elt '(nil nil)))))))
(t
(check-variable elt "optional parameter")
(when normalize-optional
(setf elt (cons elt '(nil nil))))))
(push (ensure-list elt) optional))
(&rest
(check-variable elt "rest parameter")
(setf rest elt
state :after-rest))
(&key
(cond ((consp elt)
(destructuring-bind (var-or-kv &rest tail) elt
(cond ((consp var-or-kv)
(destructuring-bind (keyword var) var-or-kv
(unless (symbolp keyword)
(simple-program-error "Invalid keyword name ~S in ordinary ~
lambda-list:~% ~S"
keyword lambda-list))
(check-variable var "keyword parameter")))
(t
(check-variable var-or-kv "keyword parameter")
(when normalize-keyword
(setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
(cond ((cdr tail)
(check-spec tail "keyword-supplied-p parameter"))
((and normalize-keyword tail)
(setf tail (append tail '(nil))))
(normalize-keyword
(setf tail '(nil nil))))
(setf elt (cons var-or-kv tail))))
(t
(check-variable elt "keyword parameter")
(setf elt (if normalize-keyword
(list (list (make-keyword elt) elt) nil nil)
elt))))
(push elt keys))
(&aux
(if (consp elt)
(destructuring-bind (var &optional init) elt
(declare (ignore init))
(check-variable var "&aux parameter"))
(progn
(check-variable elt "&aux parameter")
(setf elt (list* elt (when normalize-auxilary
'(nil))))))
(push elt aux))
(t
(simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
(values (nreverse required) (nreverse optional) rest (nreverse keys)
allow-other-keys (nreverse aux) keyp)))
;;;; DESTRUCTURING-*CASE
(defun expand-destructuring-case (key clauses case)
(once-only (key)
`(if (typep ,key 'cons)
(,case (car ,key)
,@(mapcar (lambda (clause)
(destructuring-bind ((keys . lambda-list) &body body) clause
`(,keys
(destructuring-bind ,lambda-list (cdr ,key)
,@body))))
clauses))
(error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
(defmacro destructuring-case (keyform &body clauses)
"DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
KEYFORM must evaluate to a CONS.
Clauses are of the form:
((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
is selected, and FORMs are then executed with CDR of KEY is destructured and
bound by the DESTRUCTURING-LAMBDA-LIST.
Example:
(defun dcase (x)
(destructuring-case x
((:foo a b)
(format nil \"foo: ~S, ~S\" a b))
((:bar &key a b)
(format nil \"bar: ~S, ~S\" a b))
(((:alt1 :alt2) a)
(format nil \"alt: ~S\" a))
((t &rest rest)
(format nil \"unknown: ~S\" rest))))
(dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
(dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
(dcase (list :alt1 1)) ; => \"alt: 1\"
(dcase (list :alt2 2)) ; => \"alt: 2\"
(dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
(defun decase (x)
(destructuring-case x
((:foo a b)
(format nil \"foo: ~S, ~S\" a b))
((:bar &key a b)
(format nil \"bar: ~S, ~S\" a b))
(((:alt1 :alt2) a)
(format nil \"alt: ~S\" a))))
(decase (list :foo 1 2)) ; => \"foo: 1, 2\"
(decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
(decase (list :alt1 1)) ; => \"alt: 1\"
(decase (list :alt2 2)) ; => \"alt: 2\"
(decase (list :quux 1 2 3)) ; =| error
"
(expand-destructuring-case keyform clauses 'case))
(defmacro destructuring-ccase (keyform &body clauses)
(expand-destructuring-case keyform clauses 'ccase))
(defmacro destructuring-ecase (keyform &body clauses)
(expand-destructuring-case keyform clauses 'ecase))
(dolist (name '(destructuring-ccase destructuring-ecase))
(setf (documentation name 'function) (documentation 'destructuring-case 'function)))

295
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/numbers.lisp Normal file
View file

@ -0,0 +1,295 @@
(in-package :alexandria)
(declaim (inline clamp))
(defun clamp (number min max)
"Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
(if (< number min)
min
(if (> number max)
max
number)))
(defun gaussian-random (&optional min max)
"Returns two gaussian random double floats as the primary and secondary value,
optionally constrained by MIN and MAX. Gaussian random numbers form a standard
normal distribution around 0.0d0.
Sufficiently positive MIN or negative MAX will cause the algorithm used to
take a very long time. If MIN is positive it should be close to zero, and
similarly if MAX is negative it should be close to zero."
(macrolet
((valid (x)
`(<= (or min ,x) ,x (or max ,x)) ))
(labels
((gauss ()
(loop
for x1 = (- (random 2.0d0) 1.0d0)
for x2 = (- (random 2.0d0) 1.0d0)
for w = (+ (expt x1 2) (expt x2 2))
when (< w 1.0d0)
do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
(return (values (* x1 v) (* x2 v))))))
(guard (x)
(unless (valid x)
(tagbody
:retry
(multiple-value-bind (x1 x2) (gauss)
(when (valid x1)
(setf x x1)
(go :done))
(when (valid x2)
(setf x x2)
(go :done))
(go :retry))
:done))
x))
(multiple-value-bind
(g1 g2) (gauss)
(values (guard g1) (guard g2))))))
(declaim (inline iota))
(defun iota (n &key (start 0) (step 1))
"Return a list of n numbers, starting from START (with numeric contagion
from STEP applied), each consequtive number being the sum of the previous one
and STEP. START defaults to 0 and STEP to 1.
Examples:
(iota 4) => (0 1 2 3)
(iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
(iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
"
(declare (type (integer 0) n) (number start step))
(loop ;; KLUDGE: get numeric contagion right for the first element too
for i = (+ (- (+ start step) step)) then (+ i step)
repeat n
collect i))
(declaim (inline map-iota))
(defun map-iota (function n &key (start 0) (step 1))
"Calls FUNCTION with N numbers, starting from START (with numeric contagion
from STEP applied), each consequtive number being the sum of the previous one
and STEP. START defaults to 0 and STEP to 1. Returns N.
Examples:
(map-iota #'print 3 :start 1 :step 1.0) => 3
;;; 1.0
;;; 2.0
;;; 3.0
"
(declare (type (integer 0) n) (number start step))
(loop ;; KLUDGE: get numeric contagion right for the first element too
for i = (+ start (- step step)) then (+ i step)
repeat n
do (funcall function i))
n)
(declaim (inline lerp))
(defun lerp (v a b)
"Returns the result of linear interpolation between A and B, using the
interpolation coefficient V."
;; The correct version is numerically stable, at the expense of an
;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
;; unstable version can often be converted to a fast instruction on
;; a lot of machines, though this is machine/implementation
;; specific. As alexandria is more about correct code, than
;; efficiency, and we're only talking about a single extra multiply,
;; many would prefer the stable version
(+ (* (- 1.0 v) a) (* v b)))
(declaim (inline mean))
(defun mean (sample)
"Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
(/ (reduce #'+ sample) (length sample)))
(defun median (sample)
"Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
;; Implements and uses the quick-select algorithm to find the median
;; https://en.wikipedia.org/wiki/Quickselect
(labels ((randint-in-range (start-int end-int)
"Returns a random integer in the specified range, inclusive"
(+ start-int (random (1+ (- end-int start-int)))))
(partition (vec start-i end-i)
"Implements the partition function, which performs a partial
sort of vec around the (randomly) chosen pivot.
Returns the index where the pivot element would be located
in a correctly-sorted array"
(if (= start-i end-i)
start-i
(let ((pivot-i (randint-in-range start-i end-i)))
(rotatef (aref vec start-i) (aref vec pivot-i))
(let ((swap-i end-i))
(loop for i from swap-i downto (1+ start-i) do
(when (>= (aref vec i) (aref vec start-i))
(rotatef (aref vec i) (aref vec swap-i))
(decf swap-i)))
(rotatef (aref vec swap-i) (aref vec start-i))
swap-i)))))
(let* ((vector (copy-sequence 'vector sample))
(len (length vector))
(mid-i (ash len -1))
(i 0)
(j (1- len)))
(loop for correct-pos = (partition vector i j)
while (/= correct-pos mid-i) do
(if (< correct-pos mid-i)
(setf i (1+ correct-pos))
(setf j (1- correct-pos))))
(if (oddp len)
(aref vector mid-i)
(* 1/2
(+ (aref vector mid-i)
(reduce #'max (make-array
mid-i
:displaced-to vector))))))))
(declaim (inline variance))
(defun variance (sample &key (biased t))
"Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
sequence of numbers."
(let ((mean (mean sample)))
(/ (reduce (lambda (a b)
(+ a (expt (- b mean) 2)))
sample
:initial-value 0)
(- (length sample) (if biased 0 1)))))
(declaim (inline standard-deviation))
(defun standard-deviation (sample &key (biased t))
"Standard deviation of SAMPLE. Returns the biased standard deviation if
BIASED is true (the default), and the square root of the unbiased estimator
for variance if BIASED is false (which is not the same as the unbiased
estimator for standard deviation). SAMPLE must be a sequence of numbers."
(sqrt (variance sample :biased biased)))
(define-modify-macro maxf (&rest numbers) max
"Modify-macro for MAX. Sets place designated by the first argument to the
maximum of its original value and NUMBERS.")
(define-modify-macro minf (&rest numbers) min
"Modify-macro for MIN. Sets place designated by the first argument to the
minimum of its original value and NUMBERS.")
;;;; Factorial
;;; KLUDGE: This is really dependant on the numbers in question: for
;;; small numbers this is larger, and vice versa. Ideally instead of a
;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
(defconstant +factorial-bisection-range-limit+ 8)
;;; KLUDGE: This is really platform dependant: ideally we would use
;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
(defconstant +factorial-direct-multiplication-limit+ 13)
(defun %multiply-range (i j)
;; We use a a bit of cleverness here:
;;
;; 1. For large factorials we bisect in order to avoid expensive bignum
;; multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
;; and once it does that all further multiplications will be with bignums.
;;
;; By instead doing the multiplication in a tree like
;; ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
;; we manage to get less bignums.
;;
;; 2. Division isn't exactly free either, however, so we don't bisect
;; all the way down, but multiply ranges of integers close to each
;; other directly.
;;
;; For even better results it should be possible to use prime
;; factorization magic, but Nikodemus ran out of steam.
;;
;; KLUDGE: We support factorials of bignums, but it seems quite
;; unlikely anyone would ever be able to use them on a modern lisp,
;; since the resulting numbers are unlikely to fit in memory... but
;; it would be extremely unelegant to define FACTORIAL only on
;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
;; needed.
(labels ((bisect (j k)
(declare (type (integer 1 #.most-positive-fixnum) j k))
(if (< (- k j) +factorial-bisection-range-limit+)
(multiply-range j k)
(let ((middle (+ j (truncate (- k j) 2))))
(* (bisect j middle)
(bisect (+ middle 1) k)))))
(bisect-big (j k)
(declare (type (integer 1) j k))
(if (= j k)
j
(let ((middle (+ j (truncate (- k j) 2))))
(* (if (<= middle most-positive-fixnum)
(bisect j middle)
(bisect-big j middle))
(bisect-big (+ middle 1) k)))))
(multiply-range (j k)
(declare (type (integer 1 #.most-positive-fixnum) j k))
(do ((f k (* f m))
(m (1- k) (1- m)))
((< m j) f)
(declare (type (integer 0 (#.most-positive-fixnum)) m)
(type unsigned-byte f)))))
(if (and (typep i 'fixnum) (typep j 'fixnum))
(bisect i j)
(bisect-big i j))))
(declaim (inline factorial))
(defun %factorial (n)
(if (< n 2)
1
(%multiply-range 1 n)))
(defun factorial (n)
"Factorial of non-negative integer N."
(check-type n (integer 0))
(%factorial n))
;;;; Combinatorics
(defun binomial-coefficient (n k)
"Binomial coefficient of N and K, also expressed as N choose K. This is the
number of K element combinations given N choises. N must be equal to or
greater then K."
(check-type n (integer 0))
(check-type k (integer 0))
(assert (>= n k))
(if (or (zerop k) (= n k))
1
(let ((n-k (- n k)))
;; Swaps K and N-K if K < N-K because the algorithm
;; below is faster for bigger K and smaller N-K
(when (< k n-k)
(rotatef k n-k))
(if (= 1 n-k)
n
;; General case, avoid computing the 1x...xK twice:
;;
;; N! 1x...xN (K+1)x...xN
;; -------- = ---------------- = ------------, N>1
;; K!(N-K)! 1x...xK x (N-K)! (N-K)!
(/ (%multiply-range (+ k 1) n)
(%factorial n-k))))))
(defun subfactorial (n)
"Subfactorial of the non-negative integer N."
(check-type n (integer 0))
(if (zerop n)
1
(do ((x 1 (1+ x))
(a 0 (* x (+ a b)))
(b 1 a))
((= n x) a))))
(defun count-permutations (n &optional (k n))
"Number of K element permutations for a sequence of N objects.
K defaults to N"
(check-type n (integer 0))
(check-type k (integer 0))
(assert (>= n k))
(%multiply-range (1+ (- n k)) n))

243
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/package.lisp Normal file
View file

@ -0,0 +1,243 @@
(defpackage :alexandria.1.0.0
(:nicknames :alexandria)
(:use :cl)
#+sb-package-locks
(:lock t)
(:export
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BLESSED
;;
;; Binding constructs
#:if-let
#:when-let
#:when-let*
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REVIEW IN PROGRESS
;;
;; Control flow
;;
;; -- no clear consensus yet --
#:cswitch
#:eswitch
#:switch
;; -- problem free? --
#:multiple-value-prog2
#:nth-value-or
#:whichever
#:xor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REVIEW PENDING
;;
;; Definitions
#:define-constant
;; Hash tables
#:alist-hash-table
#:copy-hash-table
#:ensure-gethash
#:hash-table-alist
#:hash-table-keys
#:hash-table-plist
#:hash-table-values
#:maphash-keys
#:maphash-values
#:plist-hash-table
;; Functions
#:compose
#:conjoin
#:curry
#:disjoin
#:ensure-function
#:ensure-functionf
#:multiple-value-compose
#:named-lambda
#:rcurry
;; Lists
#:alist-plist
#:appendf
#:nconcf
#:reversef
#:nreversef
#:circular-list
#:circular-list-p
#:circular-tree-p
#:doplist
#:ensure-car
#:ensure-cons
#:ensure-list
#:flatten
#:lastcar
#:make-circular-list
#:map-product
#:mappend
#:nunionf
#:plist-alist
#:proper-list
#:proper-list-length
#:proper-list-p
#:remove-from-plist
#:remove-from-plistf
#:delete-from-plist
#:delete-from-plistf
#:set-equal
#:setp
#:unionf
;; Numbers
#:binomial-coefficient
#:clamp
#:count-permutations
#:factorial
#:gaussian-random
#:iota
#:lerp
#:map-iota
#:maxf
#:mean
#:median
#:minf
#:standard-deviation
#:subfactorial
#:variance
;; Arrays
#:array-index
#:array-length
#:copy-array
;; Sequences
#:copy-sequence
#:deletef
#:emptyp
#:ends-with
#:ends-with-subseq
#:extremum
#:first-elt
#:last-elt
#:length=
#:map-combinations
#:map-derangements
#:map-permutations
#:proper-sequence
#:random-elt
#:removef
#:rotate
#:sequence-of-length-p
#:shuffle
#:starts-with
#:starts-with-subseq
;; Macros
#:once-only
#:parse-body
#:parse-ordinary-lambda-list
#:with-gensyms
#:with-unique-names
;; Symbols
#:ensure-symbol
#:format-symbol
#:make-gensym
#:make-gensym-list
#:make-keyword
;; Strings
#:string-designator
;; Types
#:negative-double-float
#:negative-fixnum-p
#:negative-float
#:negative-float-p
#:negative-long-float
#:negative-long-float-p
#:negative-rational
#:negative-rational-p
#:negative-real
#:negative-single-float-p
#:non-negative-double-float
#:non-negative-double-float-p
#:non-negative-fixnum
#:non-negative-fixnum-p
#:non-negative-float
#:non-negative-float-p
#:non-negative-integer-p
#:non-negative-long-float
#:non-negative-rational
#:non-negative-real-p
#:non-negative-short-float-p
#:non-negative-single-float
#:non-negative-single-float-p
#:non-positive-double-float
#:non-positive-double-float-p
#:non-positive-fixnum
#:non-positive-fixnum-p
#:non-positive-float
#:non-positive-float-p
#:non-positive-integer
#:non-positive-rational
#:non-positive-real
#:non-positive-real-p
#:non-positive-short-float
#:non-positive-short-float-p
#:non-positive-single-float-p
#:positive-double-float
#:positive-double-float-p
#:positive-fixnum
#:positive-fixnum-p
#:positive-float
#:positive-float-p
#:positive-integer
#:positive-rational
#:positive-real
#:positive-real-p
#:positive-short-float
#:positive-short-float-p
#:positive-single-float
#:positive-single-float-p
#:coercef
#:negative-double-float-p
#:negative-fixnum
#:negative-integer
#:negative-integer-p
#:negative-real-p
#:negative-short-float
#:negative-short-float-p
#:negative-single-float
#:non-negative-integer
#:non-negative-long-float-p
#:non-negative-rational-p
#:non-negative-real
#:non-negative-short-float
#:non-positive-integer-p
#:non-positive-long-float
#:non-positive-long-float-p
#:non-positive-rational-p
#:non-positive-single-float
#:of-type
#:positive-integer-p
#:positive-long-float
#:positive-long-float-p
#:positive-rational-p
#:type=
;; Conditions
#:required-argument
#:ignore-some-conditions
#:simple-style-warning
#:simple-reader-error
#:simple-parse-error
#:simple-program-error
#:unwind-protect-case
;; Features
#:featurep
;; io
#:with-input-from-file
#:with-output-to-file
#:read-stream-content-into-string
#:read-file-into-string
#:write-string-into-file
#:read-stream-content-into-byte-vector
#:read-file-into-byte-vector
#:write-byte-vector-into-file
#:copy-stream
#:copy-file
;; new additions collected at the end (subject to removal or further changes)
#:symbolicate
#:assoc-value
#:rassoc-value
#:destructuring-case
#:destructuring-ccase
#:destructuring-ecase
))

555
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/sequences.lisp Normal file
View file

@ -0,0 +1,555 @@
(in-package :alexandria)
;; Make these inlinable by declaiming them INLINE here and some of them
;; NOTINLINE at the end of the file. Exclude functions that have a compiler
;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
(declaim (inline copy-sequence sequence-of-length-p))
(defun sequence-of-length-p (sequence length)
"Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
SEQUENCE is not a sequence. Returns FALSE for circular lists."
(declare (type array-index length)
#-lispworks (inline length)
(optimize speed))
(etypecase sequence
(null
(zerop length))
(cons
(let ((n (1- length)))
(unless (minusp n)
(let ((tail (nthcdr n sequence)))
(and tail
(null (cdr tail)))))))
(vector
(= length (length sequence)))
(sequence
(= length (length sequence)))))
(defun rotate-tail-to-head (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod n (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((tail (last sequence (+ m 1)))
(last (cdr tail)))
(setf (cdr tail) nil)
(nconc last sequence))))
(let* ((len (length sequence))
(m (mod n len))
(tail (subseq sequence (- len m))))
(replace sequence sequence :start1 m :start2 0)
(replace sequence tail)
sequence)))
(defun rotate-head-to-tail (sequence n)
(declare (type (integer 1) n))
(if (listp sequence)
(let ((m (mod (1- n) (proper-list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((headtail (nthcdr m sequence))
(tail (cdr headtail)))
(setf (cdr headtail) nil)
(nconc tail sequence))))
(let* ((len (length sequence))
(m (mod n len))
(head (subseq sequence 0 m)))
(replace sequence sequence :start1 0 :start2 m)
(replace sequence head :start1 (- len m))
sequence)))
(defun rotate (sequence &optional (n 1))
"Returns a sequence of the same type as SEQUENCE, with the elements of
SEQUENCE rotated by N: N elements are moved from the end of the sequence to
the front if N is positive, and -N elements moved from the front to the end if
N is negative. SEQUENCE must be a proper sequence. N must be an integer,
defaulting to 1.
If absolute value of N is greater then the length of the sequence, the results
are identical to calling ROTATE with
(* (signum n) (mod n (length sequence))).
Note: the original sequence may be destructively altered, and result sequence may
share structure with it."
(if (plusp n)
(rotate-tail-to-head sequence n)
(if (minusp n)
(rotate-head-to-tail sequence (- n))
sequence)))
(defun shuffle (sequence &key (start 0) end)
"Returns a random permutation of SEQUENCE bounded by START and END.
Original sequence may be destructively modified, and (if it contains
CONS or lists themselv) share storage with the original one.
Signals an error if SEQUENCE is not a proper sequence."
(declare (type fixnum start)
(type (or fixnum null) end))
(etypecase sequence
(list
(let* ((end (or end (proper-list-length sequence)))
(n (- end start)))
(do ((tail (nthcdr start sequence) (cdr tail)))
((zerop n))
(rotatef (car tail) (car (nthcdr (random n) tail)))
(decf n))))
(vector
(let ((end (or end (length sequence))))
(loop for i from start below end
do (rotatef (aref sequence i)
(aref sequence (+ i (random (- end i))))))))
(sequence
(let ((end (or end (length sequence))))
(loop for i from (- end 1) downto start
do (rotatef (elt sequence i)
(elt sequence (+ i (random (- end i)))))))))
sequence)
(defun random-elt (sequence &key (start 0) end)
"Returns a random element from SEQUENCE bounded by START and END. Signals an
error if the SEQUENCE is not a proper non-empty sequence, or if END and START
are not proper bounding index designators for SEQUENCE."
(declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
(let* ((size (if (listp sequence)
(proper-list-length sequence)
(length sequence)))
(end2 (or end size)))
(cond ((zerop size)
(error 'type-error
:datum sequence
:expected-type `(and sequence (not (satisfies emptyp)))))
((not (and (<= 0 start) (< start end2) (<= end2 size)))
(error 'simple-type-error
:datum (cons start end)
:expected-type `(cons (integer 0 (,end2))
(or null (integer (,start) ,size)))
:format-control "~@<~S and ~S are not valid bounding index designators for ~
a sequence of length ~S.~:@>"
:format-arguments (list start end size)))
(t
(let ((index (+ start (random (- end2 start)))))
(elt sequence index))))))
(declaim (inline remove/swapped-arguments))
(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
(apply #'remove item sequence keyword-arguments))
(define-modify-macro removef (item &rest keyword-arguments)
remove/swapped-arguments
"Modify-macro for REMOVE. Sets place designated by the first argument to
the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
(declaim (inline delete/swapped-arguments))
(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
(apply #'delete item sequence keyword-arguments))
(define-modify-macro deletef (item &rest keyword-arguments)
delete/swapped-arguments
"Modify-macro for DELETE. Sets place designated by the first argument to
the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
(deftype proper-sequence ()
"Type designator for proper sequences, that is proper lists and sequences
that are not lists."
`(or proper-list
(and (not list) sequence)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (find-package '#:sequence)
(find-symbol (string '#:emptyp) '#:sequence))
(pushnew 'sequence-emptyp *features*)))
#-alexandria::sequence-emptyp
(defun emptyp (sequence)
"Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
is not a sequence."
(etypecase sequence
(list (null sequence))
(sequence (zerop (length sequence)))))
#+alexandria::sequence-emptyp
(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
#+alexandria::sequence-emptyp
(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
#+alexandria::sequence-emptyp
(define-compiler-macro emptyp (sequence)
`(sequence:emptyp ,sequence))
(defun length= (&rest sequences)
"Takes any number of sequences or integers in any order. Returns true iff
the length of all the sequences and the integers are equal. Hint: there's a
compiler macro that expands into more efficient code if the first argument
is a literal integer."
(declare (dynamic-extent sequences)
(inline sequence-of-length-p)
(optimize speed))
(unless (cdr sequences)
(error "You must call LENGTH= with at least two arguments"))
;; There's room for optimization here: multiple list arguments could be
;; traversed in parallel.
(let* ((first (pop sequences))
(current (if (integerp first)
first
(length first))))
(declare (type array-index current))
(dolist (el sequences)
(if (integerp el)
(unless (= el current)
(return-from length= nil))
(unless (sequence-of-length-p el current)
(return-from length= nil)))))
t)
(define-compiler-macro length= (&whole form length &rest sequences)
(cond
((zerop (length sequences))
form)
(t
(let ((optimizedp (integerp length)))
(with-unique-names (tmp current)
(declare (ignorable current))
`(locally
(declare (inline sequence-of-length-p))
(let ((,tmp)
,@(unless optimizedp
`((,current ,length))))
,@(unless optimizedp
`((unless (integerp ,current)
(setf ,current (length ,current)))))
(and
,@(loop
:for sequence :in sequences
:collect `(progn
(setf ,tmp ,sequence)
(if (integerp ,tmp)
(= ,tmp ,(if optimizedp
length
current))
(sequence-of-length-p ,tmp ,(if optimizedp
length
current)))))))))))))
(defun copy-sequence (type sequence)
"Returns a fresh sequence of TYPE, which has the same elements as
SEQUENCE."
(if (typep sequence type)
(copy-seq sequence)
(coerce sequence type)))
(defun first-elt (sequence)
"Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, or is an empty sequence."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(car sequence))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(elt sequence 0))
(t
(error 'type-error
:datum sequence
:expected-type '(and sequence (not (satisfies emptyp)))))))
(defun (setf first-elt) (object sequence)
"Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(cond ((consp sequence)
(setf (car sequence) object))
((and (typep sequence 'sequence) (not (emptyp sequence)))
(setf (elt sequence 0) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and sequence (not (satisfies emptyp)))))))
(defun last-elt (sequence)
"Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
not a proper sequence, or is an empty sequence."
;; Can't just directly use ELT, as it is not guaranteed to signal the
;; type-error.
(let ((len 0))
(cond ((consp sequence)
(lastcar sequence))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(elt sequence (1- len)))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun (setf last-elt) (object sequence)
"Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
(let ((len 0))
(cond ((consp sequence)
(setf (lastcar sequence) object))
((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
(setf (elt sequence (1- len)) object))
(t
(error 'type-error
:datum sequence
:expected-type '(and proper-sequence (not (satisfies emptyp))))))))
(defun starts-with-subseq (prefix sequence &rest args
&key
(return-suffix nil return-suffix-supplied-p)
&allow-other-keys)
"Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the function returns, as a second value, a
sub-sequence or displaced array pointing to the sequence after PREFIX."
(declare (dynamic-extent args))
(let ((sequence-length (length sequence))
(prefix-length (length prefix)))
(when (< sequence-length prefix-length)
(return-from starts-with-subseq (values nil nil)))
(flet ((make-suffix (start)
(when return-suffix
(cond
((not (arrayp sequence))
(if start
(subseq sequence start)
(subseq sequence 0 0)))
((not start)
(make-array 0
:element-type (array-element-type sequence)
:adjustable nil))
(t
(make-array (- sequence-length start)
:element-type (array-element-type sequence)
:displaced-to sequence
:displaced-index-offset start
:adjustable nil))))))
(let ((mismatch (apply #'mismatch prefix sequence
(if return-suffix-supplied-p
(remove-from-plist args :return-suffix)
args))))
(cond
((not mismatch)
(values t (make-suffix nil)))
((= mismatch prefix-length)
(values t (make-suffix mismatch)))
(t
(values nil nil)))))))
(defun ends-with-subseq (suffix sequence &key (test #'eql))
"Test whether SEQUENCE ends with SUFFIX. In other words: return true if
the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
(let ((sequence-length (length sequence))
(suffix-length (length suffix)))
(when (< sequence-length suffix-length)
;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
(return-from ends-with-subseq nil))
(loop for sequence-index from (- sequence-length suffix-length) below sequence-length
for suffix-index from 0 below suffix-length
when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
do (return-from ends-with-subseq nil)
finally (return t))))
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
(let ((first-elt (typecase sequence
(cons (car sequence))
(sequence
(if (emptyp sequence)
(return-from starts-with nil)
(elt sequence 0)))
(t
(return-from starts-with nil)))))
(funcall test (funcall key first-elt) object)))
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
"Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
an error if SEQUENCE is an improper list."
(let ((last-elt (typecase sequence
(cons
(lastcar sequence)) ; signals for improper lists
(sequence
;; Can't use last-elt, as that signals an error
;; for empty sequences
(let ((len (length sequence)))
(if (plusp len)
(elt sequence (1- len))
(return-from ends-with nil))))
(t
(return-from ends-with nil)))))
(funcall test (funcall key last-elt) object)))
(defun map-combinations (function sequence &key (start 0) end length (copy t))
"Calls FUNCTION with each combination of LENGTH constructable from the
elements of the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
delimited subsequence. (So unless LENGTH is specified there is only a single
combination, which has the same elements as the delimited subsequence.) If
COPY is true (the default) each combination is freshly allocated. If COPY is
false all combinations are EQ to each other, in which case consequences are
unspecified if a combination is modified by FUNCTION."
(let* ((end (or end (length sequence)))
(size (- end start))
(length (or length size))
(combination (subseq sequence 0 length))
(function (ensure-function function)))
(if (= length size)
(funcall function combination)
(flet ((call ()
(funcall function (if copy
(copy-seq combination)
combination))))
(etypecase sequence
;; When dealing with lists we prefer walking back and
;; forth instead of using indexes.
(list
(labels ((combine-list (c-tail o-tail)
(if (not c-tail)
(call)
(do ((tail o-tail (cdr tail)))
((not tail))
(setf (car c-tail) (car tail))
(combine-list (cdr c-tail) (cdr tail))))))
(combine-list combination (nthcdr start sequence))))
(vector
(labels ((combine (count start)
(if (zerop count)
(call)
(loop for i from start below end
do (let ((j (- count 1)))
(setf (aref combination j) (aref sequence i))
(combine j (+ i 1)))))))
(combine length start)))
(sequence
(labels ((combine (count start)
(if (zerop count)
(call)
(loop for i from start below end
do (let ((j (- count 1)))
(setf (elt combination j) (elt sequence i))
(combine j (+ i 1)))))))
(combine length start)))))))
sequence)
(defun map-permutations (function sequence &key (start 0) end length (copy t))
"Calls function with each permutation of LENGTH constructable
from the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of the sequence, and LENGTH to the
length of the delimited subsequence."
(let* ((end (or end (length sequence)))
(size (- end start))
(length (or length size)))
(labels ((permute (seq n)
(let ((n-1 (- n 1)))
(if (zerop n-1)
(funcall function (if copy
(copy-seq seq)
seq))
(loop for i from 0 upto n-1
do (permute seq n-1)
(if (evenp n-1)
(rotatef (elt seq 0) (elt seq n-1))
(rotatef (elt seq i) (elt seq n-1)))))))
(permute-sequence (seq)
(permute seq length)))
(if (= length size)
;; Things are simple if we need to just permute the
;; full START-END range.
(permute-sequence (subseq sequence start end))
;; Otherwise we need to generate all the combinations
;; of LENGTH in the START-END range, and then permute
;; a copy of the result: can't permute the combination
;; directly, as they share structure with each other.
(let ((permutation (subseq sequence 0 length)))
(flet ((permute-combination (combination)
(permute-sequence (replace permutation combination))))
(declare (dynamic-extent #'permute-combination))
(map-combinations #'permute-combination sequence
:start start
:end end
:length length
:copy nil)))))))
(defun map-derangements (function sequence &key (start 0) end (copy t))
"Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
by the bounding index designators START and END. Derangement is a permutation
of the sequence where no element remains in place. SEQUENCE is not modified,
but individual derangements are EQ to each other. Consequences are unspecified
if calling FUNCTION modifies either the derangement or SEQUENCE."
(let* ((end (or end (length sequence)))
(size (- end start))
;; We don't really care about the elements here.
(derangement (subseq sequence 0 size))
;; Bitvector that has 1 for elements that have been deranged.
(mask (make-array size :element-type 'bit :initial-element 0)))
(declare (dynamic-extent mask))
;; ad hoc algorith
(labels ((derange (place n)
;; Perform one recursive step in deranging the
;; sequence: PLACE is index of the original sequence
;; to derange to another index, and N is the number of
;; indexes not yet deranged.
(if (zerop n)
(funcall function (if copy
(copy-seq derangement)
derangement))
;; Itarate over the indexes I of the subsequence to
;; derange: if I != PLACE and I has not yet been
;; deranged by an earlier call put the element from
;; PLACE to I, mark I as deranged, and recurse,
;; finally removing the mark.
(loop for i from 0 below size
do
(unless (or (= place (+ i start)) (not (zerop (bit mask i))))
(setf (elt derangement i) (elt sequence place)
(bit mask i) 1)
(derange (1+ place) (1- n))
(setf (bit mask i) 0))))))
(derange start size)
sequence)))
(declaim (notinline sequence-of-length-p))
(defun extremum (sequence predicate &key key (start 0) end)
"Returns the element of SEQUENCE that would appear first if the subsequence
bounded by START and END was sorted using PREDICATE and KEY.
EXTREMUM determines the relationship between two elements of SEQUENCE by using
the PREDICATE function. PREDICATE should return true if and only if the first
argument is strictly less than the second one (in some appropriate sense). Two
arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
and (FUNCALL PREDICATE Y X) are both false.
The arguments to the PREDICATE function are computed from elements of SEQUENCE
using the KEY function, if supplied. If KEY is not supplied or is NIL, the
sequence element itself is used.
If SEQUENCE is empty, NIL is returned."
(let* ((pred-fun (ensure-function predicate))
(key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
(ensure-function key)))
(real-end (or end (length sequence))))
(cond ((> real-end start)
(if key-fun
(flet ((reduce-keys (a b)
(if (funcall pred-fun
(funcall key-fun a)
(funcall key-fun b))
a
b)))
(declare (dynamic-extent #'reduce-keys))
(reduce #'reduce-keys sequence :start start :end real-end))
(flet ((reduce-elts (a b)
(if (funcall pred-fun a b)
a
b)))
(declare (dynamic-extent #'reduce-elts))
(reduce #'reduce-elts sequence :start start :end real-end))))
((= real-end start)
nil)
(t
(error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
(length sequence)
:start start
:end end)))))

6
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/strings.lisp Normal file
View file

@ -0,0 +1,6 @@
(in-package :alexandria)
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
`(or symbol string character))

65
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/symbols.lisp Normal file
View file

@ -0,0 +1,65 @@
(in-package :alexandria)
(declaim (inline ensure-symbol))
(defun ensure-symbol (name &optional (package *package*))
"Returns a symbol with name designated by NAME, accessible in package
designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
interned there. Returns a secondary value reflecting the status of the symbol
in the package, which matches the secondary return value of INTERN.
Example:
(ensure-symbol :cons :cl) => cl:cons, :external
"
(intern (string name) package))
(defun maybe-intern (name package)
(values
(if package
(intern name (if (eq t package) *package* package))
(make-symbol name))))
(declaim (inline format-symbol))
(defun format-symbol (package control &rest arguments)
"Constructs a string by applying ARGUMENTS to string designator CONTROL as
if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
by that string.
If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
symbol interned in the current package, and otherwise returns a symbol
interned in the package designated by PACKAGE."
(maybe-intern (with-standard-io-syntax
(apply #'format nil (string control) arguments))
package))
(defun make-keyword (name)
"Interns the string designated by NAME in the KEYWORD package."
(intern (string name) :keyword))
(defun make-gensym (name)
"If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
must be a string designator, in which case calls GENSYM using the designated
string as the argument."
(gensym (if (typep name '(integer 0))
name
(string name))))
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
using the second (optional, defaulting to \"G\") argument."
(let ((g (if (typep x '(integer 0)) x (string x))))
(loop repeat length
collect (gensym g))))
(defun symbolicate (&rest things)
"Concatenate together the names of some strings and symbols,
producing a symbol in the current package."
(let* ((length (reduce #'+ things
:key (lambda (x) (length (string x)))))
(name (make-array length :element-type 'character)))
(let ((index 0))
(dolist (thing things (values (intern name)))
(let* ((x (string thing))
(len (length x)))
(replace name x :start1 index)
(incf index len))))))

2047
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/tests.lisp Normal file
View file

File diff suppressed because it is too large Load diff

137
sbcl/.quicklisp/dists/quicklisp/software/alexandria-20191227-git/types.lisp Normal file
View file

@ -0,0 +1,137 @@
(in-package :alexandria)
(deftype array-index (&optional (length (1- array-dimension-limit)))
"Type designator for an index into array of LENGTH: an integer between
0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
ARRAY-DIMENSION-LIMIT."
`(integer 0 (,length)))
(deftype array-length (&optional (length (1- array-dimension-limit)))
"Type designator for a dimension of an array of LENGTH: an integer between
0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
ARRAY-DIMENSION-LIMIT."
`(integer 0 ,length))
;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
;; except the RATIO related definitions and ARRAY-INDEX.
(macrolet
((frob (type &optional (base-type type))
(let ((subtype-names (list))
(predicate-names (list)))
(flet ((make-subtype-name (format-control)
(let ((result (format-symbol :alexandria format-control
(symbol-name type))))
(push result subtype-names)
result))
(make-predicate-name (sybtype-name)
(let ((result (format-symbol :alexandria '#:~A-p
(symbol-name sybtype-name))))
(push result predicate-names)
result))
(make-docstring (range-beg range-end range-type)
(let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
(format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
type
(if (equal range-beg ''*) inf (ensure-car range-beg))
(if (equal range-end ''*) inf (ensure-car range-end))))))
(let* ((negative-name (make-subtype-name '#:negative-~a))
(non-positive-name (make-subtype-name '#:non-positive-~a))
(non-negative-name (make-subtype-name '#:non-negative-~a))
(positive-name (make-subtype-name '#:positive-~a))
(negative-p-name (make-predicate-name negative-name))
(non-positive-p-name (make-predicate-name non-positive-name))
(non-negative-p-name (make-predicate-name non-negative-name))
(positive-p-name (make-predicate-name positive-name))
(negative-extremum)
(positive-extremum)
(below-zero)
(above-zero)
(zero))
(setf (values negative-extremum below-zero
above-zero positive-extremum zero)
(ecase type
(fixnum (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
(integer (values ''* -1 1 ''* 0))
(rational (values ''* '(0) '(0) ''* 0))
(real (values ''* '(0) '(0) ''* 0))
(float (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
(short-float (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
(single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
(double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
(long-float (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
`(progn
(deftype ,negative-name ()
,(make-docstring negative-extremum below-zero :negative)
`(,',base-type ,,negative-extremum ,',below-zero))
(deftype ,non-positive-name ()
,(make-docstring negative-extremum zero :negative)
`(,',base-type ,,negative-extremum ,',zero))
(deftype ,non-negative-name ()
,(make-docstring zero positive-extremum :positive)
`(,',base-type ,',zero ,,positive-extremum))
(deftype ,positive-name ()
,(make-docstring above-zero positive-extremum :positive)
`(,',base-type ,',above-zero ,,positive-extremum))
(declaim (inline ,@predicate-names))
(defun ,negative-p-name (n)
(and (typep n ',type)
(< n ,zero)))
(defun ,non-positive-p-name (n)
(and (typep n ',type)
(<= n ,zero)))
(defun ,non-negative-p-name (n)
(and (typep n ',type)
(<= ,zero n)))
(defun ,positive-p-name (n)
(and (typep n ',type)
(< ,zero n)))))))))
(frob fixnum integer)
(frob integer)
(frob rational)
(frob real)
(frob float)
(frob short-float)
(frob single-float)
(frob double-float)
(frob long-float))
(defun of-type (type)
"Returns a function of one argument, which returns true when its argument is
of TYPE."
(lambda (thing) (typep thing type)))
(define-compiler-macro of-type (&whole form type &environment env)
;; This can yeild a big benefit, but no point inlining the function
;; all over the place if TYPE is not constant.
(if (constantp type env)
(with-gensyms (thing)
`(lambda (,thing)
(typep ,thing ,type)))
form))
(declaim (inline type=))
(defun type= (type1 type2)
"Returns a primary value of T is TYPE1 and TYPE2 are the same type,
and a secondary value that is true is the type equality could be reliably
determined: primary value of NIL and secondary value of T indicates that the
types are not equivalent."
(multiple-value-bind (sub ok) (subtypep type1 type2)
(cond ((and ok sub)
(subtypep type2 type1))
(ok
(values nil ok))
(t
(multiple-value-bind (sub ok) (subtypep type2 type1)
(declare (ignore sub))
(values nil ok))))))
(define-modify-macro coercef (type-spec) coerce
"Modify-macro for COERCE.")

1
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.gitref Normal file
View file

@ -0,0 +1 @@
c1f15e2bd02fabe7bb468b05fe311cd9a932f14f

41
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/.travis.yml Normal file
View file

@ -0,0 +1,41 @@
language: emacs
env:
# we test emacs23 with sbcl only
- "CHECK_TARGET=check LISP=sbcl EMACS=emacs23"
- "CHECK_TARGET=check-fancy LISP=sbcl EMACS=emacs23"
# for emacs24, use more combinations
- "CHECK_TARGET=check LISP=sbcl EMACS=emacs24"
#- "CHECK_TARGET=check LISP=cmucl EMACS=emacs24"
- "CHECK_TARGET=check LISP=ccl EMACS=emacs24"
- "CHECK_TARGET=check-fancy LISP=sbcl EMACS=emacs24"
#- "CHECK_TARGET=check-fancy LISP=cmucl EMACS=emacs24"
- "CHECK_TARGET=check-fancy LISP=ccl EMACS=emacs24"
# also, for emacs24/sbcl test some more contribs in isolation
- "CHECK_TARGET=check-repl LISP=sbcl EMACS=emacs24"
- "CHECK_TARGET=check-indentation LISP=sbcl EMACS=emacs24"
install:
- curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash
- if [ "$EMACS" = "emacs23" ]; then
sudo apt-get -qq update &&
sudo apt-get -qq -f install &&
sudo apt-get -qq install emacs23-nox;
fi
- if [ "$EMACS" = "emacs24" ]; then
sudo add-apt-repository -y ppa:cassou/emacs &&
sudo apt-get -qq update &&
sudo apt-get -qq -f install &&
sudo apt-get -qq install emacs24-nox;
fi
script:
- make LISP=$LISP EMACS=$EMACS $CHECK_TARGET
notifications:
email:
recipients:
- slime-cvs@common-lisp.net
# on_success: always # for testing

153
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/CONTRIBUTING.md Normal file
View file

@ -0,0 +1,153 @@
# The SLIME Hacker's Handbook
## Lisp code file structure
The Lisp code is organised into these files:
* `swank-backend.lisp`: Definition of the interface to non-portable
features. Stand-alone.
* `swank-<cmucl|...>.lisp`: Backend implementation for a specific
Common Lisp system. Uses swank-backend.lisp.
* `swank.lisp`: The top-level server program, built from the other
components. Uses swank-backend.lisp as an interface to the actual
backends.
* `slime.el`: The Superior Lisp Inferior Mode for Emacs, i.e. the
Emacs frontend that the user actually interacts with and that connects
to the SWANK server to send expressions to, and retrieve information
from the running Common Lisp system.
* `contrib/*.lisp`: Lisp related code for add-ons to SLIME that are
maintained by their respective authors. Consult contrib/README for
more information.
## Test Suite
The Makefile includes a `check` target to run the ERT-based test
suite. This can give a pretty good sanity-check for your changes
Some backends do not pass the full test suite because of missing
features. In these cases the test suite is still useful to ensure that
changes don't introduce new errors. CMUCL historically passes the full
test suite so it makes a good sanity check for fundamental changes
(e.g. to the protocol).
Running the test suite, adding new cases, and increasing the number of
cases that backends support are all very good for karma.
## Source code layout
We use a special source file layout to take advantage of some fancy
Emacs features: outline-mode and "narrowing".
### Outline structure
Our source files have a hierarchical structure using comments like
these:
```el
;;;; Heading
;;;;; Subheading
... etc
```
We do this as a nice way to structure the program. We try to keep each
(sub)section small enough to fit in your head: typically around 50-200
lines of code each. Each section usually begins with a brief
introduction, followed by its highest-level functions, followed by
their subroutines. This is a pleasing shape for a source file to have.
Of course the comments mean something to Emacs too. One handy usage is
to bring up a hyperlinked "table of contents" for the source file
using this command:
```el
(defun show-outline-structure ()
"Show the outline-mode structure of the current buffer."
(interactive)
(occur (concat "^" outline-regexp)))
```
Another is to use `outline-minor-mode` to fold away certain parts of
the buffer. See the `Outline Mode` section of the Emacs manual for
details about that.
### Pagebreak characters (^L)
We partition source files into chunks using pagebreak characters. Each
chunk is a substantial piece of code that can be considered in
isolation, that could perhaps be a separate source file if we were
fanatical about small source files (rather than big ones!)
The page breaks usually go in the same place as top-level outline-mode
headings, but they don't have to. They're flexible.
In the old days, when `slime.el` was less than 100 pages long, these
page breaks were helpful when printing it out to read. Now they're
useful for something else: narrowing.
You can use `C-x n p` (`narrow-to-page`) to "zoom in" on a
pagebreak-delimited section of the file as if it were a separate
buffer in itself. You can then use `C-x n w` (`widen`) to "zoom out" and
see the whole file again. This is tremendously helpful for focusing
your attention on one part of the program as if it were its own file.
(This file contains some page break characters. If you're reading in
Emacs you can press `C-x n p` to narrow to this page, and then later
`C-x n w` to make the whole buffer visible again.)
## Coding style
We like the fact that each function in SLIME will fit on a single
screen (80x20), and would like to preserve this property! Beyond that
we're not dogmatic :-)
In early discussions we all made happy noises about the advice in
Norvig and Pitman's
[Tutorial on Good Lisp Programming Style](http://www.norvig.com/luv-slides.ps).
For Emacs Lisp, we try to follow the _Tips and Conventions_ in
Appendix D of the GNU Emacs Lisp Reference Manual (see Info file
`elisp`, node `Tips`).
We use Emacs conventions for docstrings: the first line should be a
complete sentence to make the output of `apropos` look good. We also
use imperative verbs.
Now that XEmacs support is gone, rewrites using packages in GNU
Emacs's core get extra karma.
Customization variables complicate testing and therefore we only add
new ones after careful consideration. Adding new customization
variables is bad for karma.
We generally neither use nor recommend eval-after-load.
The biggest problem with SLIME's code base is feature creep. Keep in
mind that the Right Thing isn't always the Smart Thing. If you can't
find an elegant solution to a problem then you're probably solving the
wrong problem. It's often a good idea to simplify the problem and to
ignore rarely needed cases.
_Remember that to rewrite a program better is the sincerest form of
code appreciation. When you can see a way to rewrite a part of SLIME
better, please do so!_
## Pull requests
* Read [how to properly contribute to open source projects on Github][1].
* Use a topic branch to easily amend a pull request later, if necessary.
* Open a [pull request][2] that relates to *only* one subject with a
clear title and description in grammatically correct, complete
sentences.
* Write [good commit messages][3].
[1]: http://gun.io/blog/how-to-github-fork-branch-and-pull-request
[2]: https://help.github.com/articles/using-pull-requests
[3]: http://chris.beams.io/posts/git-commit/

113
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/Makefile Normal file
View file

@ -0,0 +1,113 @@
### Makefile for SLIME
#
# This file is in the public domain.
# Variables
#
EMACS=emacs
LISP=sbcl
LOAD_PATH=-L .
ELFILES := slime.el slime-autoloads.el slime-tests.el $(wildcard lib/*.el)
ELCFILES := $(ELFILES:.el=.elc)
default: compile contrib-compile
all: compile
help:
@printf "\
Main targets\n\
all -- see compile\n\
compile -- compile .el files\n\
check -- run tests in batch mode\n\
clean -- delete generated files\n\
doc-help -- print help about doc targets\n\
help-vars -- print info about variables\n\
help -- print this message\n"
help-vars:
@printf "\
Main make variables:\n\
EMACS -- program to start Emacs ($(EMACS))\n\
LISP -- program to start Lisp ($(LISP))\n\
SELECTOR -- selector for ERT tests ($(SELECTOR))\n"
# Compilation
#
slime.elc: slime.el lib/hyperspec.elc
%.elc: %.el
$(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $<
compile: $(ELCFILES)
# Automated tests
#
SELECTOR=t
check: compile
$(EMACS) -Q --batch $(LOAD_PATH) \
--eval "(require 'slime-tests)" \
--eval "(slime-setup)" \
--eval "(setq inferior-lisp-program \"$(LISP)\")" \
--eval '(slime-batch-test (quote $(SELECTOR)))'
# run tests interactively
#
# FIXME: Not terribly useful until bugs in ert-run-tests-interactively
# are fixed.
test: compile
$(EMACS) -Q -nw $(LOAD_PATH) \
--eval "(require 'slime-tests)" \
--eval "(slime-setup)" \
--eval "(setq inferior-lisp-program \"$(LISP)\")" \
--eval '(slime-batch-test (quote $(SELECTOR)))'
compile-swank:
echo '(load "swank-loader.lisp")' '(swank-loader:init :setup nil)' \
| $(LISP)
run-swank:
{ echo \
'(load "swank-loader.lisp")' \
'(swank-loader:init)' \
'(swank:create-server)' \
&& cat; } \
| $(LISP)
elpa-slime:
echo "Not implemented yet: elpa-slime target" && exit 255
elpa: elpa-slime contrib-elpa
# Cleanup
#
FASLREGEX = .*\.\(fasl\|ufasl\|sse2f\|lx32fsl\|abcl\|fas\|lib\|trace\)$$
clean-fasls:
find . -regex '$(FASLREGEX)' -exec rm -v {} \;
[ ! -d ~/.slime/fasl ] || rm -rf ~/.slime/fasl
clean: clean-fasls
find . -iname '*.elc' -exec rm {} \;
# Contrib stuff. Should probably also go to contrib/
#
MAKECONTRIB=$(MAKE) -C contrib EMACS="$(EMACS)" LISP="$(LISP)"
contrib-check-% check-%:
$(MAKECONTRIB) $(@:contrib-%=%)
contrib-elpa:
$(MAKECONTRIB) elpa-all
contrib-compile:
$(MAKECONTRIB) compile
# Doc
#
doc-%:
$(MAKE) -C doc $(@:doc-%=%)
doc: doc-help
.PHONY: clean elpa compile check doc dist

609
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/NEWS Normal file
View file

@ -0,0 +1,609 @@
* SLIME News -*- mode: outline; coding: utf-8 -*-
* 2.24 (May 2019)
*** Minor improvements.
* 2.23 (December 2018)
*** Improved compatiblity with different versions of Emacs, SBCL, Clasp, Allegro.
*** Bug fixes
* 2.22 (July 2018)
*** Improved compatiblity with Emacs 26
* 2.21 (June 2018)
*** Improved compatiblity with Emacs 26
*** Mezzano support
* 2.20 (August 2017)
** Core
*** More secure handling of ~/.slime-secret
** SBCL backend
*** Compatiblity with the latest SBCL and older SBCL.
** ECL backend
*** Numerous enhancements
* 2.19 (February 2017)
** Core
*** Function `create-server` now accepts optional `interface` argument.
Swank will bind the PORT on this interface. By default, interface is 127.0.0.1.
This argument can be used, for example, to bind swank on IPv6 interface "::1".
** SBCL backend
*** Now swank can be bound to IPv6 interface and can work on IPv6-only machines.
*** Compatiblity with the latest SBCL
* 2.18 (May 2016)
*** Mostly bug fixes and compatibility with newer implementations
* 2.17 (February 2016)
** Contribs
*** New contrib, slime-macrostep, for more advanced in-place macroexpansion.
*** New contrib, slime-quicklisp.
* 2.16 (January 2016)
*** Auto-completion now supports package-local nicknames on SBCL and ABCL.
*** Bug fixes and updates for newer implementations.
* 2.15 (August 2015)
** Core
*** Completions are now displayed with `completion-at-point'.
The new variable `slime-completion-at-point-functions' should now be
used to customize completion. The old variable
`slime-complete-symbol-function' still works, but it is considered
obsolete and will be removed eventually.
** SBCL backend
*** M-. can locate forms within PROGN/MACROLET/etc. Needs SBCL 1.2.15
* 2.14 (June 2015)
** Core
*** Rationals are displayed in the echo area as floats too
*** Some of SLDB's faces now have MORE COLOR
*** Clicking with mouse-1 within inspector does things
As do mouse-6 and mouse-7. (Thanks to Attila Lendvai.)
** slime-c-p-c (Compound Prefix Completion)
*** Now takes a better guess at symbol case (issue #233)
** slime-fancy
*** slime-mdot-fu is now enabled by default
** SBCL backend
*** Now able to jump to ir1-translators, declaims and alien types
*** Various updates supporting SBCL 1.2.12
** ABCL backend
*** Fixed inspection of frame-locals in the debugger
(Thanks to Mark Evenson.)
* 2.13 (March 2015)
** Core
*** slime-cycle-connections has been deprecated
It has been replaced by slime-next-connection and
slime-prev-connection. A shortcut for the latter has been added to
slime-selector.
** slime-mdot-fu
The slime-mdot-fu contrib has been brought back to life. (Thanks to Charles
Zhang. Issues #8, #231 and #232.)
** slime-typeout-frame
The slime-typeout-frame contrib has been restored. (Issue #221.)
** SBCL backend
*** Fixed xrefs coming from C-c C-c
Issue #227.
** CMUCL, SBCL and SCL backends
*** Better support for custom readtables
Functionality that depends on SWANK's source-path-parser, such as
`slime-find-definition', now works properly in face of custom
readtables by honoring SWANK:*READTABLE-ALIST*. (Thanks to Gábor
Melis. PR #244.)
** Kawa backend
*** Updated for Kawa version 2.0
* 2.12 (January 2015)
** Core
A couple of regressions introduced in version 2.10 were fixed.
*** slime-compile-buffer (C-c C-k) no longer tries to save every buffer
*** slime-autodoc-mode doesn't spam the minibuffer anymore
** SWANK
*** CREATE-SERVER provides interactive restarts when port is taken
Thanks to Adlai Chandrasekhar. (PR #204.)
** slime-fuzzy
New variable *FUZZY-DUPLICATE-SYMBOL-FILTER* allows customization of
how symbols accessible from multiple packages should be
canonicalized. Defaults to :NEAREST-PACKAGE, a departure from the
previous default behaviour which is still available using
:HOME-PACKAGE. The new behaviour expands "ui:e-l" to
"uiop:ensure-list" rather than "uiop/utility:ensure-list". Consult the
manual for other options and other details.
Thanks to Ivan Shvedunov. (PR #205.)
* 2.11 (December 2014)
** MELPA is now an officially supported installation method
Various bugs involving installation and upgrading via package.el were
fixed. See the README for more details. (Issues #125, #195, #208.)
** Core
*** Compilation via the xref buffer now works again
** slime-repl / slime-presentations
Only text to the left of the cursor should limit the scope of history
navigation. Fixed a long-standing bug that violated this when
slime-presentations was enabled. (Thanks to Ivan Shvedunov. PR #207.)
** slime-package-fu
Now handles strings as symbol designators, is mindful of trailing
whitespace and properly handles an :export clause immediately
following the package name. (Thanks to Leo Liu. PR #145.)
** slime-indentation
The edge case handling described in slime-cl-indent.el:958 have been
has been restored.
** Allegro CL backend
Support for mlisp was restored. It had been broken by the previous
release. (Reported by Alexandre Rademaker. Issue #209.)
** New experimental SWANK backend for MLWorks
** SWANK
swank-listener-hooks was restored. (Thanks to Ivan Shvedunov. PR #210.)
* 2.10.1 (October 2014)
*** The SWANK-BACKEND nickname has been added to the SWANK/BACKEND package
This should ease the migration of external projects that depend on the
SWANK-BACKEND package. However, note that SWANK/BACKEND (as well as
the other SWANK/* packages) are internal packages. Please refer to
Conium <http://www.cliki.net/conium> for a project that purports to
offer a stable API for debugger- and compiler-related tasks in Common
Lisp.
* 2.10 (October 2014)
** Core
*** The SWANK-BACKEND package has been renamed to SWANK/BACKEND
Furthermore, implementations of the SWANK-BACKEND interface have
individual packages such as SWANK/SBCL, SWANK/CCL, etc. Other packages
such as SWANK-RPC, SWANK-GRAY have likewise had their hyphens turned
into slashes.
*** slime-compile-file is now aware of compilation-ask-about-save
When set to nil, SLIME will save modified buffers without asking.
compilation-save-buffers-predicate can be used to customize which
buffers should be automatically saved.
** slime-repl
*** Clearing REPL output no longer deletes the prompt (issue #183)
** slime-autodoc
This contrib has been rewritten. Please report any regressions you may
find.
** ABCL backend
*** Inspecting CLOS objects works properly again
*** SLDB frame arguments have become inspectable
** SBCL backend
*** Source locations involving the #. reader macro
The aforementioned mechanism was adapted to recent changes in the
internals of the SBCL reader.
*** Breakage involving recent versions of SBCL on Windows was fixed (issue #192)
We no longer assume SB-SYS:ENABLE-INTERRUPT exists on Windows SBCL.
** MKCL backend
New backend for ManKai Common Lisp.
** CMUCL backend
*** Support for versions prior to 20c has been removed
** MIT Scheme backend
*** Updated and now requires MIT Scheme 9.2
* 2.9 (August 2014)
** Core
*** Various display-related bugfixes
** CMUCL
*** M-. now works on condition classes
* 2.8 (July 2014)
** Core
*** Inspector fixes and improvements for SBCL.
** Contribs
*** Kawa backend supports Kawa 1.14.
* 2.7 (June 2014)
** Core
*** SWANK now tries harder to send double-floats to Emacs
** Allegro CL Backend
*** Added implementation for FUNCTION-NAME and FIND-SOURCE-LOCATION interfaces
Notably, this means that pressing "." in the SLIME inspector now works
on Allegro CL. (Thanks to Gábor Melis.)
* 2.6 (May 2014)
** Core
*** *print-readably* bound to nil when displaying condition messages
*** Issue #144: Removed nicknames and short package names
The STD nickname for SWANK-TRACE-DIALOG was removed. MONITOR was
renamed to SWANK-MONITOR and its nickname MON removed.
*** Issues #135, #154: slime-to-lisp-filename used more pervasively
Now used for the both the port-file and loader file when announced
from Emacs to the lisp backend. Allows a user-written
`slime-to-lisp-filename-function' that supports Cygwin lisps with
non-Cygwin Emacsen or vice-versa. See #135 for an example of such a
function.
*** Issue #155: Stale SLDB buffers are now properly removed
Indirect exits from an SLDB buffer that was not selected in a window
would leave a stale buffer behind, leading to an inconsistent state
and unexpected errors.
** Contribs
*** Issue #139: Restored "copy to REPL" for slime-presentations
`slime-copy-presentation-at-point-to-repl' will copy a presentation to
the REPL, place it at point, and _not_ set *, ** and ***. This
behaviour restored after refactorings of "copy to REPL" behaviour of
previous versions.
*** Issue #140: Improvements in the "copy to REPL" behaviour
With or without the slime-presentations contrib, M-RET will
copy/return values to REPL from both Inspector and SLDB buffers,
setting *, ** and *** . If the slime-presentations contrib is enabled,
the returned part will be an interactive presentation. The protocol
for copying down parts to REPL has been reworked to not assume a CL
backend .
*** Now supports more CLHS references: :type, :system-class, :ansi-cl
*** Issue #133: Fixed links to the SBCL manual
** Backend improvements
*** SBCL
**** `slime-set-default-directory' now calls chdir
This propagates its effects to subprocesses.
* 2.5 (April 2014)
** Backend improvements
*** Clozure CL
**** `slime-set-default-directory' now calls chdir
This propagates its effects to subprocesses.
*** Allegro CL
**** swank-compile-string no longer binds *default-pathname-defaults*
This was inconsistent with the behaviour of other backends and caused
strange issues with SYS:TEMPORARY-DIRECTORY.
**** Improved source file recording
Whenever possible interactive definition compilation is mapped to the
actual source file rather than the buffer name to avoid breakage when
the the buffer name changes or is closed.
** SLIME Trace Dialog
*** (Un)Tracing a definition automatically updates the trace status
** slime-repl
*** Inspecting * in REPL no longer inspects ** (issue #137)
** slime-autodoc
*** Multiline arglists in `slime-autodoc' no longer imply a newline (issue #7)
** Core Bugfixes
*** SWANK port file name defined in more portable fashion
Bug reported by Mirko Vukovic on slime-devel.
*** inferior-lisp-program can now hold paths with spaces (issue #116)
* 2.4 (March 2014)
** New contrib SLIME Trace Dialog included in `slime-fancy'
Interactive interface to tracing functions and methods. See manual for
details.
** New contrib `slime-fancy-trace', included in `slime-fancy'
If your implementation allows it, trace complex method signatures,
labels, etc...
** New options in `slime-cl-indent.el' used by the `slime-indentation' contrib
New variables are `lisp-loop-body-forms-indentation' and
`lisp-loop-body-forms-indentation'.
** New command `sldb-copy-down-to-repl' bound to M-RET in debugger
Copies the frame variable under point to the REPL, much as
`slime-inspector-copy-down-to-repl' does.
** New command `slime-delete-package'
** UTF8 encoding
SLIME now uses only UTF8 to encode strings on the wire. Customization
variables like `slime-net-coding-system' or `swank:*coding-system*' are
now useless.
** Setup recipe
In preparation for a more decentralized approach to SLIME contribs,
the setup recipe has been slightly changed, hopefully in a backwards
compatible way. Calling `slime-setup' is no longer required. Instead,
the `slime-contribs' variable can be customized with a list of
contribs to be loaded when `M-x slime' is first executed. See section
`8.1 Loading Contrib Packages' of the SLIME Manual for more details.
** Bugfixes and stability improvements since the move to Github
*** Issue #9: new REPL output respectes existing REPL results or presentations.
*** Issue #17: TAB no longer freezes the REPL in "read-mode"
*** Issue #42: compiles on Emacs 24
*** Issue #43: `just-one-space' no longer breaks REPL
*** Issue #34: "Error in timer" error when starting slime on emacs24
*** Printing conditions is now a bit safer in the debugger (git:bafeb86)
*** Fix undo behavior in the REPL (git:af354d7)
Previously, undo would obliterate previous prompts.
*** Fix REPL type-ahead behaviour when presentations active (git:38a1826)
Input typed before your lisp responds is appended to the result when it arrives.
*** Fix package and dir synch when no process buffer (git:dc88935)
Sometimes process buffer has been killed, but connection is still active.
*** M-p on any part of the REPL buffer no longer errors (git:dc88935)
*** slime-presentations can be enabled in inspector (git:647c3c3, 2f57b34)
Set `slime-inspector-insert-ispec-function' to
`slime-presentation-inspector-insert-ispec' to use them.
*** M-. on a presentation on the REPL now longer errors
This happened when `slime-presentations' was enabled, either by itself
or by `slime-fancy'.
*** M-. on the first position of a *slime-apropos* buffer no longer fails.
This happened with the `slime-fancy-inspector.el' contrib.
*** RET on no part in *inspector* buffer no longer errors
*** slime-repsentations properly recognized when at very beginning of buffer
Fix by Attila Lendvai
*** Avoid loading `swank-asdf.lisp' if there's a good chance it will break SWANK
`swank-asdf.lisp' aborts the connection if it finds an old ASDF version.
*** In ABCL, `slime-describe-function' now works for both macros and functions.
** SLIME builds on Travis CI
See https://travis-ci.org/slime/slime for the build status and history.
** Testing framework refactored to use ERT
`def-slime-test' creates regular ERT tests. `define-slime-ert-test' is
a lighter convenience macro which automatically sets some tags for the
new tests.
** Top-level Makefile
For hackers or users using the latest version, there is now a
top-level Makefile. Use "make help" to learn about targets.
** Moved to Github
SLIME now lives in Github. The documentation and the README.md file
were updated. HACKING was renamed to CONTRIBUTING.md and updated with
Github specific instructions.
** Bugfixes and stability improvements
Since the last release and before move to Github, many bugfixes and
other changes were commited, too many to list here. See Changelog for
details.
* 2.3 (October 2011)
** REPL no longer loaded by default
SLIME has a REPL which communicates exclusively over SLIME's socket.
This REPL is no longer loaded by default. The default REPL is now the
one by the Lisp implementation in the *inferior-lisp* buffer. The
simplest way to enable the old REPL is:
(slime-setup '(slime-repl))
** Precise source tracking in Clozure CL
Recent versions of the CCL compiler support source-location tracking.
This makes the sldb-show-source command much more useful and M-. works
better too.
** Environment variables for Lisp process
slime-lisp-implementations can be used to specify a list of strings to
augment the process environment of the Lisp process. E.g.:
(sbcl-cvs
("/home/me/sbcl-cvs/src/runtime/sbcl"
"--core" "/home/me/sbcl-cvs/output/sbcl.core")
:env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/"))
* 2.1
** Removed Features
Some of the more esoteric features, like presentations or fuzzy
completion, are no longer enabled by default. A new directory
"contrib/" contains the code for these packages. To use them, you
must make some changes to your ~/.emacs. For details see, section
"Contributed Packages" in the manual.
** Stepper
Juho Snellman implemented stepping commands for SBCL.
** Completions
SLIME can now complete keywords and character names (like #\newline).
* 2.0 (April 2006)
** In-place macro expansion
Marco Baringer wrote a new minor mode to incrementally expand macros.
** Improved arglist display
SLIME now recognizes `make-instance' calls and displays the correct
arglist if the classname is present. Similarly, for `defmethod' forms
SLIME displays the arguments of the generic function.
** Persistent REPL history
SLIME now saves the command history from REPL buffers in a file and
reloads it for newly created REPL buffers.
** Scieneer Common Lisp
Douglas Crosher added support for Scieneer Common Lisp.
** SBCL
Various improvements to make SLIME work well with current SBCL versions.
** Corman Common Lisp
Espen Wiborg added support for Corman Common Lisp.
** Presentations
A new feature which associates objects in Lisp with their textual
represetation in Emacs. The text is clickable and operations on the
associated object can be invoked from a pop-up menu.
** Security
SLIME has now a simple authentication mechanism: if the file
~/.slime-secret exists we verify that Emacs and Lisp can access it.
Since both parties have access to the same file system, we assume that
we can trust each other.
* 1.2 (March 2005)
** New inspector
The lisp side now returns a specially formated list of "things" to
format which are then passed to emacs and rendered in the inspector
buffer. Things can be either text, recursivly inspectable values, or
functions to call. The new inspector has much better support CLOS
objects and methods.
** Unicode
It's now possible to send non-ascii characters to Emacs, if the
communication channel is configured properly. See the variable
`slime-net-coding-system'.
** Arglist lookup while debugging
Previously, arglist lookup was disabled while debugging. This
restriction was removed.
** Extended tracing command
It's now possible to trace individual a single methods or all methods
of a generic function. Also tracing can be restricted to situations
in which the traced function is called from a specific function.
** M-x slime-browse-classes
A simple class browser was added.
** FASL files
The fasl files for different Lisp/OS/hardware combinations are now
placed in different directories.
** Many other small improvements and bugfixes
* 1.0 (September 2004)
** slime-interrupt
The default key binding for slime-interrupt is now C-c C-b.
** sldb-inspect-condition
In SLDB 'C' is now bound to sldb-inspect-condition.
** More Menus
SLDB and the REPL have now pull-down menus.
** Global debugger hook.
A new configurable *global-debugger* to control whether
swank-debugger-hook should be installed globally is available. True by
default.
** When you call sldb-eval-in-frame with a prefix argument, the result is
now inserted in the REPL buffer.
** Compile function
For Allegro M-. works now for functions compiled with C-c C-c.
** slime-edit-definition
Better support for Allegro: works now for different type of
definitions not only. So M-. now works for e.g. classes in Allegro.
** SBCL 0.8.13
SBCL 0.8.12 is no longer supported. Support for 0.8.12 was broken for
for some time now.
* 1.0 beta (August 2004)
** autodoc global variables
The slime-autodoc-mode will now automatically show the value of a
global variable at point.
** Customize group
The customize group is expanded and better-organised.
** slime-interactive-eval
Interactive-eval commands now print their results to the REPL when
given a prefix argument.
** slime-conservative-indentation
New Elisp variable. Non-nil means that we exclude def* and with-* from
indentation-learning. The default is t.
** (slime-setup)
New function to streamline setup in ~/.emacs
** Modeline package
The package name in the modeline is now updated on an idle timer. The
message should now be more meaningful when moving around in files
containing multiple IN-PACKAGE forms.
** XREF bugfix
The XREF commands did not find symbols in the right package.
** REPL prompt
The package name in the REPL's prompt is now abbreviated to the last
`.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This
can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to
NIL.
** CMUCL source cache
The source cache is now populated on `first-change-hook'. This makes
M-. work accurately in more file modification scenarios.
** SBCL compiler errors
Detect compiler errors and make some noise. Previously certain
problems (e.g. reader-errors) could slip by quietly.
* 1.0 alpha (June 2004)
The first preview release of SLIME.

94
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/PROBLEMS Normal file
View file

@ -0,0 +1,94 @@
Known problems with SLIME -*- outline -*-
* Common to all backends
** Caution: network security
The `M-x slime' command has Lisp listen on a TCP socket and wait for
Emacs to connect, which typically takes on the order of one second. If
someone else were to connect to this socket then they could use the
SLIME protocol to control the Lisp process.
The listen socket is bound on the loopback interface in all Lisps that
support this. This way remote hosts are unable to connect.
** READ-CHAR-NO-HANG is broken
READ-CHAR-NO-HANG doesn't work properly for slime-input-streams. Due
to the way we request input from Emacs it's not possible to repeatedly
poll for input. To get any input you have to call READ-CHAR (or a
function which calls READ-CHAR).
* Backend-specific problems
** CMUCL
The default communication style :SIGIO is reportedly unreliable with
certain libraries (like libSDL) and certain platforms (like Solaris on
Sparc). It generally works very well on x86 so it remains the default.
** SBCL
The latest released version of SBCL at the time of packaging should
work. Older or newer SBCLs may or may not work. Do not use
multithreading with unpatched 2.4 Linux kernels. There are also
problems with kernel versions 2.6.5 - 2.6.10.
The (v)iew-source command in the debugger can only locate exact source
forms for code compiled at (debug 2) or higher. The default level is
lower and SBCL itself is compiled at a lower setting. Thus only
defun-granularity is available with default policies.
** LispWorks
On Windows, SLIME hangs when calling foreign functions or certain
other functions. The reason for this problem is unknown.
We only support latin1 encoding. (Unicode wouldn't be hard to add.)
** Allegro CL
Interrupting Allegro with C-c C-b can be slow. This is caused by the
a relatively large process-quantum: 2 seconds by default. Allegro
responds much faster if mp:*default-process-quantum* is set to 0.1.
** CLISP
We require version 2.49 or higher. We also require socket support, so
you may have to start CLISP with "clisp -K full".
Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends
a SIGINT signal, but the signal is either ignored or CLISP exits
immediately.
On Windows, CLISP may refuse to parse filenames like
"C:\\DOCUME~1\\johndoe\\LOCALS~1\\Temp\\slime.1424" when we actually
mean C:\Documents and Settings\johndoe\Local Settings\slime.1424. As
a workaround, you could set slime-to-lisp-filename-function to some
function that returns a string that is accepted by CLISP.
Function arguments and local variables aren't displayed properly in
the backtrace. Changes to CLISP's C code are needed to fix this
problem. Interpreted code is usually easer to debug.
M-. (find-definition) only works if the fasl file is in the same
directory as the source file.
The arglist doesn't include the proper names only "fake symbols" like
`arg1'.
** Armed Bear Common Lisp
The ABCL support is still new and experimental.
** Corman Common Lisp
We require version 2.51 or higher, with several patches (available at
http://www.grumblesmurf.org/lisp/corman-patches).
The only communication style currently supported is NIL.
Interrupting (with C-c C-b) doesn't work.
The tracing, stepping and XREF commands are not implemented along with
some debugger functionality.

78
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/README.md Normal file
View file

@ -0,0 +1,78 @@
[![Build Status](https://img.shields.io/travis/slime/slime/master.svg)](https://travis-ci.org/slime/slime) [![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime)
Overview
--------
SLIME is the Superior Lisp Interaction Mode for Emacs.
SLIME extends Emacs with support for interactive programming in Common
Lisp. The features are centered around slime-mode, an Emacs minor-mode that
complements the standard lisp-mode. While lisp-mode supports editing Lisp
source files, slime-mode adds support for interacting with a running Common
Lisp process for compilation, debugging, documentation lookup, and so on.
For much more information, consult [the manual][1].
Quick setup instructions
------------------------
1. [Set up the MELPA repository][2], if you haven't already, and install
SLIME using `M-x package-install RET slime RET`.
2. Add the following lines to your `~/.emacs` file, filling in in
the appropriate filenames:
```el
;; Set your lisp system and, optionally, some contribs
(setq inferior-lisp-program "/opt/sbcl/bin/sbcl")
(setq slime-contribs '(slime-fancy))
```
3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will
now automatically be available in your Lisp source buffers.
If you'd like to contribute to SLIME, you will want to instead follow
the manual's instructions on [how to install SLIME via Git][7].
Contribs
--------
SLIME comes with additional contributed packages or "contribs".
Contribs can be selected via the `slime-contribs` list.
The most-often used contrib is `slime-fancy`, which primarily installs a
popular set of other contributed packages. It includes a better REPL, and
many more nice features.
License
-------
SLIME is free software. All files, unless explicitly stated otherwise, are
public domain.
Contact
-------
If you have problems, first have a look at the list of
[known issues and workarounds][6].
Questions and comments are best directed to the mailing list at
`slime-devel@common-lisp.net`, but you have to [subscribe][3] first. The
mailing list archive is also available on [Gmane][4].
See the [CONTRIBUTING.md][5] file for instructions on how to contribute.
[1]: http://common-lisp.net/project/slime/doc/html/
[2]: http://melpa.org/#/getting-started
[3]: http://www.common-lisp.net/project/slime/#mailinglist
[4]: http://news.gmane.org/gmane.lisp.slime.devel
[5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md
[6]: https://github.com/slime/slime/issues?labels=workaround&state=closed
[7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git

92
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/Makefile Normal file
View file

@ -0,0 +1,92 @@
### Makefile for contribs
#
# This file is in the public domain.
EMACS=emacs
LISP=sbcl
LOAD_PATH=-L . -L ..
CONTRIBS = $(patsubst slime-%.el,%,$(wildcard slime-*.el))
CONTRIB_TESTS = $(patsubst test/slime-%-tests.el,%,$(wildcard test/slime-*.el))
SLIME_VERSION=$(shell grep "Version:" ../slime.el | grep -E -o "[0-9.]+$$")
ELFILES := $(shell find . -type f -iname "*.el")
ELCFILES := $(patsubst %.el,%.elc,$(ELFILES))
%.elc: %.el
$(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $<
compile: $(ELCFILES)
$(EMACS) -Q --batch $(LOAD_PATH) \
--eval "(batch-byte-recompile-directory 0)" .
# ELPA builds for contribs
#
$(CONTRIBS:%=elpa-%): CONTRIB=$(@:elpa-%=%)
$(CONTRIBS:%=elpa-%): CONTRIB_EL=$(CONTRIB:%=slime-%.el)
$(CONTRIBS:%=elpa-%): CONTRIB_CL=$(CONTRIB:%=swank-%.lisp)
$(CONTRIBS:%=elpa-%): CONTRIB_VERSION=$(shell ( \
grep "Version:" $(CONTRIB_EL) \
|| echo $(SLIME_VERSION) \
) | grep -E -o "[0-9.]+$$" )
$(CONTRIBS:%=elpa-%): PACKAGE=$(CONTRIB:%=slime-%-$(CONTRIB_VERSION))
$(CONTRIBS:%=elpa-%): PACKAGE_EL=$(CONTRIB:%=slime-%-pkg.el)
$(CONTRIBS:%=elpa-%): ELPA_DIR=elpa/$(PACKAGE)
$(CONTRIBS:%=elpa-%): compile
elpa_dir=$(ELPA_DIR)
mkdir -p $$elpa_dir; \
emacs --batch $(CONTRIB_EL) \
--eval "(require 'cl-lib)" \
--eval "(search-forward \"define-slime-contrib\")" \
--eval "(up-list -1)" \
--eval "(pp \
(pcase (read (point-marker)) \
(\`(define-slime-contrib ,name ,docstring . ,rest) \
\`(define-package ,name \"$(CONTRIB_VERSION)\" \
,docstring \
,(cons '(slime \"$(SLIME_VERSION)\") \
(cl-loop for form in rest \
when (eq :slime-dependencies (car form)) \
append (cl-loop for contrib in (cdr form) \
if (atom contrib) \
collect \
\`(,contrib \"$(SLIME_VERSION)\") \
else \
collect contrib))))))))" > \
$$elpa_dir/$(PACKAGE_EL); \
cp $(CONTRIB_EL) $$elpa_dir; \
[ -r $(CONTRIB_CL) ] && cp $(CONTRIB_CL) $$elpa_dir; \
ls $$elpa_dir
cd elpa && tar cvf $(PACKAGE).tar $(PACKAGE)
rm -rf $(ELPA_DIR)
elpa-all: $(CONTRIBS:%=elpa-%)
$(CONTRIB_TESTS:%=check-%): CONTRIB_NAME=$(patsubst check-%,slime-%,$@)
$(CONTRIB_TESTS:%=check-%): SELECTOR=(quote (tag contrib))
$(CONTRIB_TESTS:%=check-%): compile
$(EMACS) -Q --batch $(LOAD_PATH) -L test \
--eval "(require (quote slime))" \
--eval "(slime-setup (quote ($(CONTRIB_NAME))))" \
--eval "(require \
(intern \
(format \"%s-tests\" (quote $(CONTRIB_NAME)))))" \
--eval '(setq inferior-lisp-program "$(LISP)")' \
--eval "(slime-batch-test $(SELECTOR))"
check-all: $(CONTRIB_TESTS:%=check-%)
check-fancy: compile
$(EMACS) -Q --batch $(LOAD_PATH) -L test \
--eval "(setq debug-on-error t)" \
--eval "(require (quote slime))" \
--eval "(slime-setup (quote (slime-fancy)))" \
--eval "(mapc (lambda (sym) \
(require \
(intern (format \"%s-tests\" sym)) \
nil t)) \
(slime-contrib-all-dependencies \
(quote slime-fancy)))" \
--eval '(setq inferior-lisp-program "$(LISP)")' \
--eval '(slime-batch-test (quote (tag contrib)))'

14
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/README.md Normal file
View file

@ -0,0 +1,14 @@
This directory contains source code which may be useful to some Slime
users. `*.el` files are Emacs Lisp source and `*.lisp` files contain
Common Lisp source code. If not otherwise stated in the file itself,
the files are placed in the Public Domain.
The components in this directory are more or less detached from the
rest of Slime. They are essentially "add-ons". But Slime can also be
used without them. The code is maintained by the respective authors.
See the top level README.md for how to use packages in this directory.
Finally, the contrib `slime-fancy` is specially noteworthy, as it
represents a meta-contrib that'll load a bunch of commonly used
contribs. Look into `slime-fancy.el` to find out which.

472
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/bridge.el Normal file
View file

@ -0,0 +1,472 @@
;;; -*-Emacs-Lisp-*-
;;;%Header
;;; Bridge process filter, V1.0
;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu
;;;
;;; Send mail to ilisp@cons.org if you have problems.
;;;
;;; Send mail to majordomo@cons.org if you want to be on the
;;; ilisp mailing list.
;;; This file is part of GNU Emacs.
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY. No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing. Refer to the GNU Emacs General Public
;;; License for full details.
;;; Everyone is granted permission to copy, modify and redistribute
;;; GNU Emacs, but only under the conditions described in the
;;; GNU Emacs General Public License. A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities. It should be in a
;;; file named COPYING. Among other things, the copyright notice
;;; and this notice must be preserved on all copies.
;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting
;;; the process filter for continuous handlers.
;;; USAGE: M-x install-bridge will add a process output filter to the
;;; current buffer. Any output that the process does between
;;; bridge-start-regexp and bridge-end-regexp will be bundled up and
;;; passed to the first handler on bridge-handlers that matches the
;;; output using string-match. If bridge-prompt-regexp shows up
;;; before bridge-end-regexp, the bridge will be cancelled. If no
;;; handler matches the output, the first symbol in the output is
;;; assumed to be a buffer name and the rest of the output will be
;;; sent to that buffer's process. This can be used to communicate
;;; between processes or to set up two way interactions between Emacs
;;; and an inferior process.
;;; You can write handlers that process the output in special ways.
;;; See bridge-send-handler for the default handler. The command
;;; hand-bridge is useful for testing. Keep in mind that all
;;; variables are buffer local.
;;; YOUR .EMACS FILE:
;;;
;;; ;;; Set up load path to include bridge
;;; (setq load-path (cons "/bridge-directory/" load-path))
;;; (autoload 'install-bridge "bridge" "Install a process bridge." t)
;;; (setq bridge-hook
;;; '(lambda ()
;;; ;; Example options
;;; (setq bridge-source-insert nil) ;Don't insert in source buffer
;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer
;;; ;; Handle copy-it messages yourself
;;; (setq bridge-handlers
;;; '(("copy-it" . my-copy-handler)))))
;;; EXAMPLE:
;;; # This pipes stdin to the named buffer in a Unix shell
;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")'
;;;
;;; ls | devgnu *scratch*
(eval-when-compile
(require 'cl))
;;;%Parameters
(defvar bridge-hook nil
"Hook called when a bridge is installed by install-hook.")
(defvar bridge-start-regexp ""
"*Regular expression to match the start of a process bridge in
process output. It should be followed by a buffer name, the data to
be sent and a bridge-end-regexp.")
(defvar bridge-end-regexp ""
"*Regular expression to match the end of a process bridge in process
output.")
(defvar bridge-prompt-regexp nil
"*Regular expression for detecting a prompt. If there is a
comint-prompt-regexp, it will be initialized to that. A prompt before
a bridge-end-regexp will stop the process bridge.")
(defvar bridge-handlers nil
"Alist of (regexp . handler) for handling process output delimited
by bridge-start-regexp and bridge-end-regexp. The first entry on the
list whose regexp matches the output will be called on the process and
the delimited output.")
(defvar bridge-source-insert t
"*T to insert bridge input in the source buffer minus delimiters.")
(defvar bridge-destination-insert t
"*T for bridge-send-handler to insert bridge input into the
destination buffer minus delimiters.")
(defvar bridge-chunk-size 512
"*Long inputs send to comint processes are broken up into chunks of
this size. If your process is choking on big inputs, try lowering the
value.")
;;;%Internal variables
(defvar bridge-old-filter nil
"Old filter for a bridged process buffer.")
(defvar bridge-string nil
"The current output in the process bridge.")
(defvar bridge-in-progress nil
"The current handler function, if any, that bridge passes strings on to,
or nil if none.")
(defvar bridge-leftovers nil
"Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.")
(defvar bridge-send-to-buffer nil
"The buffer that the default bridge-handler (bridge-send-handler) is
currently sending to, or nil if it hasn't started yet. Your handler
function can use this variable also.")
(defvar bridge-last-failure ()
"Last thing that broke the bridge handler. First item is function call
(eval'able); last item is error condition which resulted. This is provided
to help handler-writers in their debugging.")
(defvar bridge-insert-function nil
"If non-nil use this instead of `bridge-insert'")
;;;%Utilities
(defun bridge-insert (output &optional _dummy)
"Insert process OUTPUT into the current buffer."
(if bridge-insert-function
(funcall bridge-insert-function output)
(if output
(let* ((buffer (current-buffer))
(process (get-buffer-process buffer))
(mark (process-mark process))
(window (selected-window))
(at-end nil))
(if (eq (window-buffer window) buffer)
(setq at-end (= (point) mark))
(setq window (get-buffer-window buffer)))
(save-excursion
(goto-char mark)
(insert output)
(set-marker mark (point)))
(if window
(progn
(if at-end (goto-char mark))
(if (not (pos-visible-in-window-p (point) window))
(let ((original (selected-window)))
(save-excursion
(select-window window)
(recenter '(center))
(select-window original))))))))))
;;;
;(defun bridge-send-string (process string)
; "Send PROCESS the contents of STRING as input.
;This is equivalent to process-send-string, except that long input strings
;are broken up into chunks of size comint-input-chunk-size. Processes
;are given a chance to output between chunks. This can help prevent processes
;from hanging when you send them long inputs on some OS's."
; (let* ((len (length string))
; (i (min len bridge-chunk-size)))
; (process-send-string process (substring string 0 i))
; (while (< i len)
; (let ((next-i (+ i bridge-chunk-size)))
; (accept-process-output)
; (process-send-string process (substring string i (min len next-i)))
; (setq i next-i)))))
;;;
(defun bridge-call-handler (handler proc string)
"Funcall HANDLER on PROC, STRING carefully. Error is caught if happens,
and user is signaled. State is put in bridge-last-failure. Returns t if
handler executed without error."
(let ((inhibit-quit nil)
(failed nil))
(condition-case err
(funcall handler proc string)
(error
(ding)
(setq failed t)
(message "bridge-handler \"%s\" failed %s (see bridge-last-failure)"
handler err)
(setq bridge-last-failure
`((funcall ',handler ',proc ,string)
"Caused: "
,err))))
(not failed)))
;;;%Handlers
(defun bridge-send-handler (process input)
"Send PROCESS INPUT to the buffer name found at the start of the
input. The input after the buffer name is sent to the buffer's
process if it has one. If bridge-destination-insert is T, the input
will be inserted into the buffer. If it does not have a process, it
will be inserted at the end of the buffer."
(if (null input)
(setq bridge-send-to-buffer nil) ; end of bridge
(let (buffer-and-start buffer-name dest to)
;; if this is first time, get the buffer out of the first line
(cond ((not bridge-send-to-buffer)
(setq buffer-and-start (read-from-string input)
buffer-name (format "%s" (car (read-from-string input)))
dest (get-buffer buffer-name)
to (get-buffer-process dest)
input (substring input (cdr buffer-and-start)))
(setq bridge-send-to-buffer dest))
(t
(setq buffer-name bridge-send-to-buffer
dest (get-buffer buffer-name)
to (get-buffer-process dest)
)))
(if dest
(let ((buffer (current-buffer)))
(if bridge-destination-insert
(unwind-protect
(progn
(set-buffer dest)
(if to
(bridge-insert process input)
(goto-char (point-max))
(insert input)))
(set-buffer buffer)))
(if to
;; (bridge-send-string to input)
(process-send-string to input)
))
(error "%s is not a buffer" buffer-name)))))
;;;%Filter
(defun bridge-filter (process output)
"Given PROCESS and some OUTPUT, check for the presence of
bridge-start-regexp. Everything prior to this will be passed to the
normal filter function or inserted in the buffer if it is nil. The
output up to bridge-end-regexp will be sent to the first handler on
bridge-handlers that matches the string. If no handlers match, the
input will be sent to bridge-send-handler. If bridge-prompt-regexp is
encountered before the bridge-end-regexp, the bridge will be cancelled."
(let ((inhibit-quit t)
(match-data (match-data))
(buffer (current-buffer))
(process-buffer (process-buffer process))
(case-fold-search t)
(start 0) (end 0)
function
b-start b-start-end b-end)
(set-buffer process-buffer) ;; access locals
;; Handle bridge messages that straddle a packet by prepending
;; them to this packet.
(when bridge-leftovers
(setq output (concat bridge-leftovers output))
(setq bridge-leftovers nil))
(setq function bridge-in-progress)
;; How it works:
;;
;; start, end delimit the part of string we are interested in;
;; initially both 0; after an iteration we move them to next string.
;; b-start, b-end delimit part of string to bridge (possibly whole string);
;; this will be string between corresponding regexps.
;; There are two main cases when we come into loop:
;; bridge in progress
;;0 setq b-start = start
;;1 setq b-end (or end-pattern end)
;;4 process string
;;5 remove handler if end found
;; no bridge in progress
;;0 setq b-start if see start-pattern
;;1 setq b-end if bstart to (or end-pattern end)
;;2 send (substring start b-start) to normal place
;;3 find handler (in b-start, b-end) if not set
;;4 process string
;;5 remove handler if end found
;; equivalent sections have the same numbers here;
;; we fold them together in this code.
(block bridge-filter
(unwind-protect
(while (< end (length output))
;;0 setq b-start if find
(setq b-start
(cond (bridge-in-progress
(setq b-start-end start)
start)
((string-match bridge-start-regexp output start)
(setq b-start-end (match-end 0))
(match-beginning 0))
(t nil)))
;;1 setq b-end
(setq b-end
(if b-start
(let ((end-seen (string-match bridge-end-regexp
output b-start-end)))
(if end-seen (setq end (match-end 0)))
end-seen)))
;; Detect and save partial bridge messages
(when (and b-start b-start-end (not b-end))
(setq bridge-leftovers (substring output b-start))
)
(if (and b-start (not b-end))
(setq end b-start)
(if (not b-end)
(setq end (length output))))
;;1.5 - if see prompt before end, remove current
(if (and b-start b-end)
(let ((prompt (string-match bridge-prompt-regexp
output b-start-end)))
(if (and prompt (<= (match-end 0) b-end))
(setq b-start nil ; b-start-end start
b-end start
end (match-end 0)
bridge-in-progress nil
))))
;;2 send (substring start b-start) to old filter, if any
(when (not (equal start (or b-start end))) ; don't bother on empty string
(let ((pass-on (substring output start (or b-start end))))
(if bridge-old-filter
(let ((old bridge-old-filter))
(store-match-data match-data)
(funcall old process pass-on)
;; if filter changed, re-install ourselves
(let ((new (process-filter process)))
(if (not (eq new 'bridge-filter))
(progn (setq bridge-old-filter new)
(set-process-filter process 'bridge-filter)))))
(set-buffer process-buffer)
(bridge-insert pass-on))))
(if (and b-start-end (not b-end))
(return-from bridge-filter t) ; when last bit has prematurely ending message, exit early.
(progn
;;3 find handler (in b-start, b-end) if none current
(if (and b-start (not bridge-in-progress))
(let ((handlers bridge-handlers))
(while (and handlers (not function))
(let* ((handler (car handlers))
(m (string-match (car handler) output b-start-end)))
(if (and m (< m b-end))
(setq function (cdr handler))
(setq handlers (cdr handlers)))))
;; Set default handler if none
(if (null function)
(setq function 'bridge-send-handler))
(setq bridge-in-progress function)))
;;4 process strin
(if function
(let ((ok t))
(if (/= b-start-end b-end)
(let ((send (substring output b-start-end b-end)))
;; also, insert the stuff in buffer between
;; iff bridge-source-insert.
(if bridge-source-insert (bridge-insert send))
;; call handler on string
(setq ok (bridge-call-handler function process send))))
;;5 remove handler if end found
;; if function removed then tell it that's all
(if (or (not ok) (/= b-end end)) ;; saw end before end-of-string
(progn
(bridge-call-handler function process nil)
;; have to remove function too for next time around
(setq function nil
bridge-in-progress nil)
))
))
;; continue looping, in case there's more string
(setq start end))
))
;; protected forms: restore buffer, match-data
(set-buffer buffer)
(store-match-data match-data)
))))
;;;%Interface
(defun install-bridge ()
"Set up a process bridge in the current buffer."
(interactive)
(if (not (get-buffer-process (current-buffer)))
(error "%s does not have a process" (buffer-name (current-buffer)))
(make-local-variable 'bridge-start-regexp)
(make-local-variable 'bridge-end-regexp)
(make-local-variable 'bridge-prompt-regexp)
(make-local-variable 'bridge-handlers)
(make-local-variable 'bridge-source-insert)
(make-local-variable 'bridge-destination-insert)
(make-local-variable 'bridge-chunk-size)
(make-local-variable 'bridge-old-filter)
(make-local-variable 'bridge-string)
(make-local-variable 'bridge-in-progress)
(make-local-variable 'bridge-send-to-buffer)
(make-local-variable 'bridge-leftovers)
(setq bridge-string nil bridge-in-progress nil
bridge-send-to-buffer nil)
(if (boundp 'comint-prompt-regexp)
(setq bridge-prompt-regexp comint-prompt-regexp))
(let ((process (get-buffer-process (current-buffer))))
(if process
(if (not (eq (process-filter process) 'bridge-filter))
(progn
(setq bridge-old-filter (process-filter process))
(set-process-filter process 'bridge-filter)))
(error "%s does not have a process"
(buffer-name (current-buffer)))))
(run-hooks 'bridge-hook)
(message "Process bridge is installed")))
;;;
(defun reset-bridge ()
"Must be called from the process's buffer. Removes any active bridge."
(interactive)
;; for when things get wedged
(if bridge-in-progress
(unwind-protect
(funcall bridge-in-progress (get-buffer-process
(current-buffer))
nil)
(setq bridge-in-progress nil))
(message "No bridge in progress.")))
;;;
(defun remove-bridge ()
"Remove bridge from the current buffer."
(interactive)
(let ((process (get-buffer-process (current-buffer))))
(if (or (not process) (not (eq (process-filter process) 'bridge-filter)))
(error "%s has no bridge" (buffer-name (current-buffer)))
;; remove any bridge-in-progress
(reset-bridge)
(set-process-filter process bridge-old-filter)
(funcall bridge-old-filter process bridge-string)
(message "Process bridge is removed."))))
;;;% Utility for testing
(defun hand-bridge (start end)
"With point at bridge-start, sends bridge-start + string +
bridge-end to bridge-filter. With prefix, use current region to send."
(interactive "r")
(let ((p0 (if current-prefix-arg (min start end)
(if (looking-at bridge-start-regexp) (point)
(error "Not looking at bridge-start-regexp"))))
(p1 (if current-prefix-arg (max start end)
(if (re-search-forward bridge-end-regexp nil t)
(point) (error "Didn't see bridge-end-regexp")))))
(bridge-filter (get-buffer-process (current-buffer))
(buffer-substring-no-properties p0 p1))
))
(provide 'bridge)

133
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/inferior-slime.el Normal file
View file

@ -0,0 +1,133 @@
;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers
;;
;; Author: Luke Gorrie <luke@synap.se>
;; License: GNU GPL (same license as Emacs)
;;
;;; Installation:
;;
;; Add something like this to your .emacs:
;;
;; (add-to-list 'load-path "<directory-of-this-file>")
;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime)))
;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1)))
(require 'slime)
(require 'cl-lib)
(define-minor-mode inferior-slime-mode
"\\<slime-mode-map>\
Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs.
This mode is intended for use with `inferior-lisp-mode'. It provides a
subset of the bindings from `slime-mode'.
\\{inferior-slime-mode-map}"
:keymap
;; Fake binding to coax `define-minor-mode' to create the keymap
'((" " 'undefined))
(slime-setup-completion)
(setq-local tab-always-indent 'complete))
(defun inferior-slime-return ()
"Handle the return key in the inferior-lisp buffer.
The current input should only be sent if a whole expression has been
entered, i.e. the parenthesis are matched.
A prefix argument disables this behaviour."
(interactive)
(if (or current-prefix-arg (inferior-slime-input-complete-p))
(comint-send-input)
(insert "\n")
(inferior-slime-indent-line)))
(defun inferior-slime-indent-line ()
"Indent the current line, ignoring everything before the prompt."
(interactive)
(save-restriction
(let ((indent-start
(save-excursion
(goto-char (process-mark (get-buffer-process (current-buffer))))
(let ((inhibit-field-text-motion t))
(beginning-of-line 1))
(point))))
(narrow-to-region indent-start (point-max)))
(lisp-indent-line)))
(defun inferior-slime-input-complete-p ()
"Return true if the input is complete in the inferior lisp buffer."
(slime-input-complete-p (process-mark (get-buffer-process (current-buffer)))
(point-max)))
(defun inferior-slime-closing-return ()
"Send the current expression to Lisp after closing any open lists."
(interactive)
(goto-char (point-max))
(save-restriction
(narrow-to-region (process-mark (get-buffer-process (current-buffer)))
(point-max))
(while (ignore-errors (save-excursion (backward-up-list 1) t))
(insert ")")))
(comint-send-input))
(defun inferior-slime-change-directory (directory)
"Set default-directory in the *inferior-lisp* buffer to DIRECTORY."
(let* ((proc (slime-process))
(buffer (and proc (process-buffer proc))))
(when buffer
(with-current-buffer buffer
(cd-absolute directory)))))
(defun inferior-slime-init-keymap ()
(let ((map inferior-slime-mode-map))
(set-keymap-parent map slime-parent-map)
(slime-define-keys map
([return] 'inferior-slime-return)
([(control return)] 'inferior-slime-closing-return)
([(meta control ?m)] 'inferior-slime-closing-return)
;;("\t" 'slime-indent-and-complete-symbol)
(" " 'slime-space))))
(inferior-slime-init-keymap)
(defun inferior-slime-hook-function ()
(inferior-slime-mode 1))
(defun inferior-slime-switch-to-repl-buffer ()
(switch-to-buffer (process-buffer (slime-inferior-process))))
(defun inferior-slime-show-transcript (string)
(remove-hook 'comint-output-filter-functions
'inferior-slime-show-transcript t)
(with-current-buffer (process-buffer (slime-inferior-process))
(let ((window (display-buffer (current-buffer) t)))
(set-window-point window (point-max)))))
(defun inferior-slime-start-transcript ()
(let ((proc (slime-inferior-process)))
(when proc
(with-current-buffer (process-buffer proc)
(add-hook 'comint-output-filter-functions
'inferior-slime-show-transcript
nil t)))))
(defun inferior-slime-stop-transcript ()
(let ((proc (slime-inferior-process)))
(when proc
(with-current-buffer (process-buffer (slime-inferior-process))
(run-with-timer 0.2 nil
(lambda (buffer)
(with-current-buffer buffer
(remove-hook 'comint-output-filter-functions
'inferior-slime-show-transcript t)))
(current-buffer))))))
(defun inferior-slime-init ()
(add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function)
(add-hook 'slime-change-directory-hooks 'inferior-slime-change-directory)
(add-hook 'slime-transcript-start-hook 'inferior-slime-start-transcript)
(add-hook 'slime-transcript-stop-hook 'inferior-slime-stop-transcript)
(def-slime-selector-method ?r
"SLIME Read-Eval-Print-Loop."
(process-buffer (slime-inferior-process))))
(provide 'inferior-slime)

313
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-asdf.el Normal file
View file

@ -0,0 +1,313 @@
(require 'slime)
(require 'cl-lib)
(require 'grep)
(define-slime-contrib slime-asdf
"ASDF support."
(:authors "Daniel Barlow <dan@telent.net>"
"Marco Baringer <mb@bese.it>"
"Edi Weitz <edi@agharta.de>"
"Stas Boukarev <stassats@gmail.com>"
"Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-asdf)
(:on-load
(add-to-list 'slime-edit-uses-xrefs :depends-on t)
(define-key slime-who-map [?d] 'slime-who-depends-on)))
;;; NOTE: `system-name' is a predefined variable in Emacs. Try to
;;; avoid it as local variable name.
;;; Utilities
(defgroup slime-asdf nil
"ASDF support for Slime."
:prefix "slime-asdf-"
:group 'slime)
(defvar slime-system-history nil
"History list for ASDF system names.")
(defun slime-read-system-name (&optional prompt
default-value
determine-default-accurately)
"Read a system name from the minibuffer, prompting with PROMPT.
If no `default-value' is given, one is tried to be determined: if
`determine-default-accurately' is true, by an RPC request which
grovels through all defined systems; if it's not true, by looking
in the directory of the current buffer."
(let* ((completion-ignore-case nil)
(prompt (or prompt "System"))
(system-names (slime-eval `(swank:list-asdf-systems)))
(default-value
(or default-value
(if determine-default-accurately
(slime-determine-asdf-system (buffer-file-name)
(slime-current-package))
(slime-find-asd-file (or default-directory
(buffer-file-name))
system-names))))
(prompt (concat prompt (if default-value
(format " (default `%s'): " default-value)
": "))))
(completing-read prompt (slime-bogus-completion-alist system-names)
nil nil nil
'slime-system-history default-value)))
(defun slime-find-asd-file (directory system-names)
"Tries to find an ASDF system definition file in the
`directory' and returns it if it's in `system-names'."
(let ((asd-files
(directory-files (file-name-directory directory) nil "\.asd$")))
(cl-loop for system in asd-files
for candidate = (file-name-sans-extension system)
when (cl-find candidate system-names :test #'string-equal)
do (cl-return candidate))))
(defun slime-determine-asdf-system (filename buffer-package)
"Try to determine the asdf system that `filename' belongs to."
(slime-eval
`(swank:asdf-determine-system ,(and filename
(slime-to-lisp-filename filename))
,buffer-package)))
(defun slime-who-depends-on-rpc (system)
(slime-eval `(swank:who-depends-on ,system)))
(defcustom slime-asdf-collect-notes t
"Collect and display notes produced by the compiler.
See also `slime-highlight-compiler-notes' and
`slime-compilation-finished-hook'."
:group 'slime-asdf)
(defun slime-asdf-operation-finished-function (system)
(if slime-asdf-collect-notes
#'slime-compilation-finished
(slime-curry (lambda (system result)
(let (slime-highlight-compiler-notes
slime-compilation-finished-hook)
(slime-compilation-finished result)))
system)))
(defun slime-oos (system operation &rest keyword-args)
"Operate On System."
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(message "Performing ASDF %S%s on system %S"
operation (if keyword-args (format " %S" keyword-args) "")
system)
(slime-repl-shortcut-eval-async
`(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args)
(slime-asdf-operation-finished-function system)))
;;; Interactive functions
(defun slime-load-system (&optional system)
"Compile and load an ASDF system.
Default system name is taken from first file matching *.asd in current
buffer's working directory"
(interactive (list (slime-read-system-name)))
(slime-oos system 'load-op))
(defun slime-open-system (name &optional load interactive)
"Open all files in an ASDF system."
(interactive (list (slime-read-system-name) nil t))
(when (or load
(and interactive
(not (slime-eval `(swank:asdf-system-loaded-p ,name)))
(y-or-n-p "Load it? ")))
(slime-load-system name))
(slime-eval-async
`(swank:asdf-system-files ,name)
(lambda (files)
(when files
(let ((files (mapcar 'slime-from-lisp-filename
(nreverse files))))
(find-file-other-window (car files))
(mapc 'find-file (cdr files)))))))
(defun slime-browse-system (name)
"Browse files in an ASDF system using Dired."
(interactive (list (slime-read-system-name)))
(slime-eval-async `(swank:asdf-system-directory ,name)
(lambda (directory)
(when directory
(dired (slime-from-lisp-filename directory))))))
(if (fboundp 'rgrep)
(defun slime-rgrep-system (sys-name regexp)
"Run `rgrep' on the base directory of an ASDF system."
(interactive (progn (grep-compute-defaults)
(list (slime-read-system-name nil nil t)
(grep-read-regexp))))
(rgrep regexp "*.lisp"
(slime-from-lisp-filename
(slime-eval `(swank:asdf-system-directory ,sys-name)))))
(defun slime-rgrep-system ()
(interactive)
(error "This command is only supported on GNU Emacs >21.x.")))
(if (boundp 'multi-isearch-next-buffer-function)
(defun slime-isearch-system (sys-name)
"Run `isearch-forward' on the files of an ASDF system."
(interactive (list (slime-read-system-name nil nil t)))
(let* ((files (mapcar 'slime-from-lisp-filename
(slime-eval `(swank:asdf-system-files ,sys-name))))
(multi-isearch-next-buffer-function
(lexical-let*
((buffers-forward (mapcar #'find-file-noselect files))
(buffers-backward (reverse buffers-forward)))
#'(lambda (current-buffer wrap)
;; Contrarily to the docstring of
;; `multi-isearch-next-buffer-function', the first
;; arg is not necessarily a buffer. Report sent
;; upstream. (2009-11-17)
(setq current-buffer (or current-buffer (current-buffer)))
(let* ((buffers (if isearch-forward
buffers-forward
buffers-backward)))
(if wrap
(car buffers)
(second (memq current-buffer buffers))))))))
(isearch-forward)))
(defun slime-isearch-system ()
(interactive)
(error "This command is only supported on GNU Emacs >23.1.x.")))
(defun slime-read-query-replace-args (format-string &rest format-args)
(let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
(minibuffer-local-map slime-minibuffer-map)
(common (query-replace-read-args (apply #'format format-string
format-args)
t t)))
(list (nth 0 common) (nth 1 common) (nth 2 common))))
(defun slime-query-replace-system (name from to &optional delimited)
"Run `query-replace' on an ASDF system."
(interactive (let ((system (slime-read-system-name nil nil t)))
(cons system (slime-read-query-replace-args
"Query replace throughout `%s'" system))))
(condition-case c
;; `tags-query-replace' actually uses `query-replace-regexp'
;; internally.
(tags-query-replace (regexp-quote from) to delimited
'(mapcar 'slime-from-lisp-filename
(slime-eval `(swank:asdf-system-files ,name))))
(error
;; Kludge: `tags-query-replace' does not actually return but
;; signals an unnamed error with the below error
;; message. (<=23.1.2, at least.)
(unless (string-equal (error-message-string c) "All files processed")
(signal (car c) (cdr c))) ; resignal
t)))
(defun slime-query-replace-system-and-dependents
(name from to &optional delimited)
"Run `query-replace' on an ASDF system and all the systems
depending on it."
(interactive (let ((system (slime-read-system-name nil nil t)))
(cons system (slime-read-query-replace-args
"Query replace throughout `%s'+dependencies"
system))))
(slime-query-replace-system name from to delimited)
(dolist (dep (slime-who-depends-on-rpc name))
(when (y-or-n-p (format "Descend into system `%s'? " dep))
(slime-query-replace-system dep from to delimited))))
(defun slime-delete-system-fasls (name)
"Delete FASLs produced by compiling a system."
(interactive (list (slime-read-system-name)))
(slime-repl-shortcut-eval-async
`(swank:delete-system-fasls ,name)
'message))
(defun slime-reload-system (system)
"Reload an ASDF system without reloading its dependencies."
(interactive (list (slime-read-system-name)))
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(message "Performing ASDF LOAD-OP on system %S" system)
(slime-repl-shortcut-eval-async
`(swank:reload-system ,system)
(slime-asdf-operation-finished-function system)))
(defun slime-who-depends-on (system-name)
(interactive (list (slime-read-system-name)))
(slime-xref :depends-on system-name))
(defun slime-save-system (system)
"Save files belonging to an ASDF system."
(interactive (list (slime-read-system-name)))
(slime-eval-async
`(swank:asdf-system-files ,system)
(lambda (files)
(dolist (file files)
(let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
(when buffer
(with-current-buffer buffer
(save-buffer buffer)))))
(message "Done."))))
;;; REPL shortcuts
(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'load-op :force t)))
(:one-liner "Recompile and load an ASDF system."))
(defslime-repl-shortcut slime-repl-load-system ("load-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'load-op)))
(:one-liner "Compile (as needed) and load an ASDF system."))
(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'test-op :force t)))
(:one-liner "Recompile and test an ASDF system."))
(defslime-repl-shortcut slime-repl-test-system ("test-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'test-op)))
(:one-liner "Compile (as needed) and test an ASDF system."))
(defslime-repl-shortcut slime-repl-compile-system ("compile-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'compile-op)))
(:one-liner "Compile (but not load) an ASDF system."))
(defslime-repl-shortcut slime-repl-compile/force-system
("force-compile-system")
(:handler (lambda ()
(interactive)
(slime-oos (slime-read-system-name) 'compile-op :force t)))
(:one-liner "Recompile (but not completely load) an ASDF system."))
(defslime-repl-shortcut slime-repl-open-system ("open-system")
(:handler 'slime-open-system)
(:one-liner "Open all files in an ASDF system."))
(defslime-repl-shortcut slime-repl-browse-system ("browse-system")
(:handler 'slime-browse-system)
(:one-liner "Browse files in an ASDF system using Dired."))
(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
(:handler 'slime-delete-system-fasls)
(:one-liner "Delete FASLs of an ASDF system."))
(defslime-repl-shortcut slime-repl-reload-system ("reload-system")
(:handler 'slime-reload-system)
(:one-liner "Recompile and load an ASDF system."))
(provide 'slime-asdf)

216
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-autodoc.el Normal file
View file

@ -0,0 +1,216 @@
(require 'slime)
(require 'eldoc)
(require 'cl-lib)
(require 'slime-parse)
(define-slime-contrib slime-autodoc
"Show fancy arglist in echo area."
(:license "GPL")
(:authors "Luke Gorrie <luke@bluetail.com>"
"Lawrence Mitchell <wence@gmx.li>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:slime-dependencies slime-parse)
(:swank-dependencies swank-arglists)
(:on-load (slime-autodoc--enable))
(:on-unload (slime-autodoc--disable)))
(defcustom slime-autodoc-accuracy-depth 10
"Number of paren levels that autodoc takes into account for
context-sensitive arglist display (local functions. etc)"
:type 'integer
:group 'slime-ui)
;;;###autoload
(defcustom slime-autodoc-mode-string (purecopy " adoc")
"String to display in mode line when Autodoc Mode is enabled; nil for none."
:type '(choice string (const :tag "None" nil))
:group 'slime-ui)
(defun slime-arglist (name)
"Show the argument list for NAME."
(interactive (list (slime-read-symbol-name "Arglist of: " t)))
(let ((arglist (slime-retrieve-arglist name)))
(if (eq arglist :not-available)
(error "Arglist not available")
(message "%s" (slime-autodoc--fontify arglist)))))
;; used also in slime-c-p-c.el.
(defun slime-retrieve-arglist (name)
(let ((name (cl-etypecase name
(string name)
(symbol (symbol-name name)))))
(car (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker))))))
(defun slime-autodoc-manually ()
"Like autodoc informtion forcing multiline display."
(interactive)
(let ((doc (slime-autodoc t)))
(cond (doc (eldoc-message doc))
(t (eldoc-message nil)))))
;; Must call eldoc-add-command otherwise (eldoc-display-message-p)
;; returns nil and eldoc clears the echo area instead.
(eldoc-add-command 'slime-autodoc-manually)
(defun slime-autodoc-space (n)
"Like `slime-space' but nicer."
(interactive "p")
(self-insert-command n)
(let ((doc (slime-autodoc)))
(when doc
(eldoc-message doc))))
(eldoc-add-command 'slime-autodoc-space)
;;;; Autodoc cache
(defvar slime-autodoc--cache-last-context nil)
(defvar slime-autodoc--cache-last-autodoc nil)
(defun slime-autodoc--cache-get (context)
"Return the cached autodoc documentation for `context', or nil."
(and (equal context slime-autodoc--cache-last-context)
slime-autodoc--cache-last-autodoc))
(defun slime-autodoc--cache-put (context autodoc)
"Update the autodoc cache for CONTEXT with AUTODOC."
(setq slime-autodoc--cache-last-context context)
(setq slime-autodoc--cache-last-autodoc autodoc))
;;;; Formatting autodoc
(defsubst slime-autodoc--canonicalize-whitespace (string)
(replace-regexp-in-string "[ \n\t]+" " " string))
(defun slime-autodoc--format (doc multilinep)
(let ((doc (slime-autodoc--fontify doc)))
(cond (multilinep doc)
(t (slime-oneliner (slime-autodoc--canonicalize-whitespace doc))))))
(defun slime-autodoc--fontify (string)
"Fontify STRING as `font-lock-mode' does in Lisp mode."
(with-current-buffer (get-buffer-create (slime-buffer-name :fontify 'hidden))
(erase-buffer)
(unless (eq major-mode 'lisp-mode)
;; Just calling (lisp-mode) will turn slime-mode on in that buffer,
;; which may interfere with this function
(setq major-mode 'lisp-mode)
(lisp-mode-variables t))
(insert string)
(let ((font-lock-verbose nil))
(font-lock-fontify-buffer))
(goto-char (point-min))
(when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t)
(let ((highlight (match-string 1)))
;; Can't use (replace-match highlight) here -- broken in Emacs 21
(delete-region (match-beginning 0) (match-end 0))
(slime-insert-propertized '(face eldoc-highlight-function-argument) highlight)))
(buffer-substring (point-min) (point-max))))
(define-obsolete-function-alias 'slime-fontify-string
'slime-autodoc--fontify
"SLIME 2.10")
;;;; Autodocs (automatic context-sensitive help)
(defun slime-autodoc (&optional force-multiline)
"Returns the cached arglist information as string, or nil.
If it's not in the cache, the cache will be updated asynchronously."
(save-excursion
(save-match-data
(let ((context (slime-autodoc--parse-context)))
(when context
(let* ((cached (slime-autodoc--cache-get context))
(multilinep (or force-multiline
eldoc-echo-area-use-multiline-p)))
(cond (cached (slime-autodoc--format cached multilinep))
(t
(when (slime-background-activities-enabled-p)
(slime-autodoc--async context multilinep))
nil))))))))
;; Return the context around point that can be passed to
;; swank:autodoc. nil is returned if nothing reasonable could be
;; found.
(defun slime-autodoc--parse-context ()
(and (slime-autodoc--parsing-safe-p)
(let ((levels slime-autodoc-accuracy-depth))
(slime-parse-form-upto-point levels))))
(defun slime-autodoc--parsing-safe-p ()
(cond ((fboundp 'slime-repl-inside-string-or-comment-p)
(not (slime-repl-inside-string-or-comment-p)))
(t
(not (slime-inside-string-or-comment-p)))))
(defun slime-autodoc--async (context multilinep)
(slime-eval-async
`(swank:autodoc ',context ;; FIXME: misuse of quote
:print-right-margin ,(window-width (minibuffer-window)))
(slime-curry #'slime-autodoc--async% context multilinep)))
(defun slime-autodoc--async% (context multilinep doc)
(cl-destructuring-bind (doc &optional cache-p) doc
(unless (eq doc :not-available)
(when cache-p
(slime-autodoc--cache-put context doc))
;; Now that we've got our information,
;; get it to the user ASAP.
(when (eldoc-display-message-p)
(eldoc-message (slime-autodoc--format doc multilinep))))))
;;; Minor mode definition
;; Compute the prefix for slime-doc-map, usually this is C-c C-d.
(defun slime-autodoc--doc-map-prefix ()
(concat
(car (rassoc '(slime-prefix-map) slime-parent-bindings))
(car (rassoc '(slime-doc-map) slime-prefix-bindings))))
(define-minor-mode slime-autodoc-mode
"Toggle echo area display of Lisp objects at point."
:lighter slime-autodoc-mode-string
:keymap (let ((prefix (slime-autodoc--doc-map-prefix)))
`((,(concat prefix "A") . slime-autodoc-manually)
(,(concat prefix (kbd "C-A")) . slime-autodoc-manually)
(,(kbd "SPC") . slime-autodoc-space)))
(set (make-local-variable 'eldoc-documentation-function) 'slime-autodoc)
(set (make-local-variable 'eldoc-minor-mode-string) nil)
(setq slime-autodoc-mode (eldoc-mode arg))
(when (called-interactively-p 'interactive)
(message "Slime autodoc mode %s."
(if slime-autodoc-mode "enabled" "disabled"))))
;;; Noise to enable/disable slime-autodoc-mode
(defun slime-autodoc--on () (slime-autodoc-mode 1))
(defun slime-autodoc--off () (slime-autodoc-mode 0))
(defvar slime-autodoc--relevant-hooks
'(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
(defun slime-autodoc--enable ()
(dolist (h slime-autodoc--relevant-hooks)
(add-hook h 'slime-autodoc--on))
(dolist (b (buffer-list))
(with-current-buffer b
(when slime-mode
(slime-autodoc--on)))))
(defun slime-autodoc--disable ()
(dolist (h slime-autodoc--relevant-hooks)
(remove-hook h 'slime-autodoc--on))
(dolist (b (buffer-list))
(with-current-buffer b
(when slime-autodoc-mode
(slime-autodoc--off)))))
(provide 'slime-autodoc)

35
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-banner.el Normal file
View file

@ -0,0 +1,35 @@
(require 'slime)
(require 'slime-repl)
(define-slime-contrib slime-banner
"Persistent header line and startup animation."
(:authors "Helmut Eller <heller@common-lisp.net>"
"Luke Gorrie <luke@synap.se>")
(:license "GPL")
(:on-load (setq slime-repl-banner-function 'slime-startup-message))
(:on-unload (setq slime-repl-banner-function 'slime-repl-insert-banner)))
(defcustom slime-startup-animation (fboundp 'animate-string)
"Enable the startup animation."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'slime-ui)
(defcustom slime-header-line-p (boundp 'header-line-format)
"If non-nil, display a header line in Slime buffers."
:type 'boolean
:group 'slime-repl)
(defun slime-startup-message ()
(when slime-header-line-p
(setq header-line-format
(format "%s Port: %s Pid: %s"
(slime-lisp-implementation-type)
(slime-connection-port (slime-connection))
(slime-pid))))
(when (zerop (buffer-size))
(let ((welcome (concat "; SLIME " slime-version)))
(if slime-startup-animation
(animate-string welcome 0 0)
(insert welcome)))))
(provide 'slime-banner)

36
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-buffer-streams.el Normal file
View file

@ -0,0 +1,36 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-buffer-streams
"Lisp streams that output to an emacs buffer"
(:authors "Ed Langley <el-github@elangley.org>")
(:license "GPL")
(:swank-dependencies swank-buffer-streams))
(defslimefun slime-make-buffer-stream-target (thread name)
(message "making target %s" name)
(slime-buffer-streams--get-target-marker name)
`(:stream-target-created ,thread ,name))
(defun slime-buffer-streams--get-target-name (target)
(format "*slime-target %s*" target))
(defvar-local slime-buffer-stream-target nil)
;; TODO: tell backend that the buffer has been closed, so it can close
;; the stream
(defun slime-buffer-streams--cleanup-markers ()
(when slime-buffer-stream-target
(message "Removing target: %s" slime-buffer-stream-target)
(remhash slime-buffer-stream-target slime-output-target-to-marker)))
(defun slime-buffer-streams--get-target-marker (target)
(or (gethash target slime-output-target-to-marker)
(with-current-buffer
(generate-new-buffer (slime-buffer-streams--get-target-name target))
(setq slime-buffer-stream-target target)
(add-hook 'kill-buffer-hook 'slime-buffer-streams--cleanup-markers)
(setf (gethash target slime-output-target-to-marker)
(point-marker)))))
(provide 'slime-buffer-streams)

305
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-c-p-c.el Normal file
View file

@ -0,0 +1,305 @@
(require 'slime)
(require 'cl-lib)
(defvar slime-c-p-c-init-undo-stack nil)
(define-slime-contrib slime-c-p-c
"ILISP style Compound Prefix Completion."
(:authors "Luke Gorrie <luke@synap.se>"
"Edi Weitz <edi@agharta.de>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-parse slime-editing-commands slime-autodoc)
(:swank-dependencies swank-c-p-c)
(:on-load
(push
`(progn
(remove-hook 'slime-completion-at-point-functions
#'slime-c-p-c-completion-at-point)
(remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
,@(when (featurep 'slime-repl)
`((define-key slime-mode-map "\C-c\C-s"
',(lookup-key slime-mode-map "\C-c\C-s"))
(define-key slime-repl-mode-map "\C-c\C-s"
',(lookup-key slime-repl-mode-map "\C-c\C-s")))))
slime-c-p-c-init-undo-stack)
(add-hook 'slime-completion-at-point-functions
#'slime-c-p-c-completion-at-point)
(define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
(when (featurep 'slime-repl)
(define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)))
(:on-unload
(while slime-c-p-c-init-undo-stack
(eval (pop slime-c-p-c-init-undo-stack)))))
(defcustom slime-c-p-c-unambiguous-prefix-p t
"If true, set point after the unambigous prefix.
If false, move point to the end of the inserted text."
:type 'boolean
:group 'slime-ui)
(defcustom slime-complete-symbol*-fancy nil
"Use information from argument lists for DWIM'ish symbol completion."
:group 'slime-mode
:type 'boolean)
;; FIXME: this is the old code to display completions. Remove it once
;; `slime-complete-symbol*' and `slime-fuzzy-complete-symbol' can be
;; used together with `completion-at-point'.
(defvar slime-completions-buffer-name "*Completions*")
;; FIXME: can probably use quit-window instead
(make-variable-buffer-local
(defvar slime-complete-saved-window-configuration nil
"Window configuration before we show the *Completions* buffer.
This is buffer local in the buffer where the completion is
performed."))
(make-variable-buffer-local
(defvar slime-completions-window nil
"The window displaying *Completions* after saving window configuration.
If this window is no longer active or displaying the completions
buffer then we can ignore `slime-complete-saved-window-configuration'."))
(defun slime-complete-maybe-save-window-configuration ()
"Maybe save the current window configuration.
Return true if the configuration was saved."
(unless (or slime-complete-saved-window-configuration
(get-buffer-window slime-completions-buffer-name))
(setq slime-complete-saved-window-configuration
(current-window-configuration))
t))
(defun slime-complete-delay-restoration ()
(add-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration
'append
'local))
(defun slime-complete-forget-window-configuration ()
(setq slime-complete-saved-window-configuration nil)
(setq slime-completions-window nil))
(defun slime-complete-restore-window-configuration ()
"Restore the window config if available."
(remove-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration)
(when (and slime-complete-saved-window-configuration
(slime-completion-window-active-p))
(save-excursion (set-window-configuration
slime-complete-saved-window-configuration))
(setq slime-complete-saved-window-configuration nil)
(when (buffer-live-p slime-completions-buffer-name)
(kill-buffer slime-completions-buffer-name))))
(defun slime-complete-maybe-restore-window-configuration ()
"Restore the window configuration, if the following command
terminates a current completion."
(remove-hook 'pre-command-hook
'slime-complete-maybe-restore-window-configuration)
(condition-case err
(cond ((cl-find last-command-event "()\"'`,# \r\n:")
(slime-complete-restore-window-configuration))
((not (slime-completion-window-active-p))
(slime-complete-forget-window-configuration))
(t
(slime-complete-delay-restoration)))
(error
;; Because this is called on the pre-command-hook, we mustn't let
;; errors propagate.
(message "Error in slime-complete-restore-window-configuration: %S"
err))))
(defun slime-completion-window-active-p ()
"Is the completion window currently active?"
(and (window-live-p slime-completions-window)
(equal (buffer-name (window-buffer slime-completions-window))
slime-completions-buffer-name)))
(defun slime-display-completion-list (completions start end)
(let ((savedp (slime-complete-maybe-save-window-configuration)))
(with-output-to-temp-buffer slime-completions-buffer-name
(display-completion-list completions)
(with-current-buffer standard-output
(setq completion-base-position (list start end))
(set-syntax-table lisp-mode-syntax-table)))
(when savedp
(setq slime-completions-window
(get-buffer-window slime-completions-buffer-name)))))
(defun slime-display-or-scroll-completions (completions start end)
(cond ((and (eq last-command this-command)
(slime-completion-window-active-p))
(slime-scroll-completions))
(t
(slime-display-completion-list completions start end)))
(slime-complete-delay-restoration))
(defun slime-scroll-completions ()
(let ((window slime-completions-window))
(with-current-buffer (window-buffer window)
(if (pos-visible-in-window-p (point-max) window)
(set-window-start window (point-min))
(save-selected-window
(select-window window)
(scroll-up))))))
(defun slime-minibuffer-respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))
(if (minibuffer-window-active-p (minibuffer-window))
(minibuffer-message text)
(message "%s" text))))
(defun slime-maybe-complete-as-filename ()
"If point is at a string starting with \", complete it as filename.
Return nil if point is not at filename."
(when (save-excursion (re-search-backward "\"[^ \t\n]+\\="
(max (point-min)
(- (point) 1000)) t))
(let ((comint-completion-addsuffix '("/" . "\"")))
(comint-replace-by-expanded-filename)
t)))
(defun slime-complete-symbol* ()
"Expand abbreviations and complete the symbol at point."
;; NB: It is only the name part of the symbol that we actually want
;; to complete -- the package prefix, if given, is just context.
(or (slime-maybe-complete-as-filename)
(slime-expand-abbreviations-and-complete)))
(defun slime-c-p-c-completion-at-point ()
#'slime-complete-symbol*)
;; FIXME: factorize
(defun slime-expand-abbreviations-and-complete ()
(let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos)))
(prefix (buffer-substring-no-properties beg end))
(completion-result (slime-contextual-completions beg end))
(completion-set (cl-first completion-result))
(completed-prefix (cl-second completion-result)))
(if (null completion-set)
(progn (slime-minibuffer-respecting-message
"Can't find completion for \"%s\"" prefix)
(ding)
(slime-complete-restore-window-configuration))
;; some XEmacs issue makes this distinction necessary
(cond ((> (length completed-prefix) (- end beg))
(goto-char end)
(insert-and-inherit completed-prefix)
(delete-region beg end)
(goto-char (+ beg (length completed-prefix))))
(t nil))
(cond ((and (member completed-prefix completion-set)
(slime-length= completion-set 1))
(slime-minibuffer-respecting-message "Sole completion")
(when slime-complete-symbol*-fancy
(slime-complete-symbol*-fancy-bit))
(slime-complete-restore-window-configuration))
;; Incomplete
(t
(when (member completed-prefix completion-set)
(slime-minibuffer-respecting-message
"Complete but not unique"))
(when slime-c-p-c-unambiguous-prefix-p
(let ((unambiguous-completion-length
(cl-loop for c in completion-set
minimizing (or (cl-mismatch completed-prefix c)
(length completed-prefix)))))
(goto-char (+ beg unambiguous-completion-length))))
(slime-display-or-scroll-completions completion-set
beg
(max (point) end)))))))
(defun slime-complete-symbol*-fancy-bit ()
"Do fancy tricks after completing a symbol.
\(Insert a space or close-paren based on arglist information.)"
(let ((arglist (slime-retrieve-arglist (slime-symbol-at-point))))
(unless (eq arglist :not-available)
(let ((args
;; Don't intern these symbols
(let ((obarray (make-vector 10 0)))
(cdr (read arglist))))
(function-call-position-p
(save-excursion
(backward-sexp)
(equal (char-before) ?\())))
(when function-call-position-p
(if (null args)
(execute-kbd-macro ")")
(execute-kbd-macro " ")
(when (and (slime-background-activities-enabled-p)
(not (minibuffer-window-active-p (minibuffer-window))))
(slime-echo-arglist))))))))
(cl-defun slime-contextual-completions (beg end)
"Return a list of completions of the token from BEG to END in the
current buffer."
(let ((token (buffer-substring-no-properties beg end)))
(cond
((and (< beg (point-max))
(string= (buffer-substring-no-properties beg (1+ beg)) ":"))
;; Contextual keyword completion
(let ((completions
(slime-completions-for-keyword token
(save-excursion
(goto-char beg)
(slime-parse-form-upto-point)))))
(when (cl-first completions)
(cl-return-from slime-contextual-completions completions))
;; If no matching keyword was found, do regular symbol
;; completion.
))
((and (>= (length token) 2)
(string= (cl-subseq token 0 2) "#\\"))
;; Character name completion
(cl-return-from slime-contextual-completions
(slime-completions-for-character token))))
;; Regular symbol completion
(slime-completions token)))
(defun slime-completions (prefix)
(slime-eval `(swank:completions ,prefix ',(slime-current-package))))
(defun slime-completions-for-keyword (prefix buffer-form)
(slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form)))
(defun slime-completions-for-character (prefix)
(cl-labels ((append-char-syntax (string) (concat "#\\" string)))
(let ((result (slime-eval `(swank:completions-for-character
,(cl-subseq prefix 2)))))
(when (car result)
(list (mapcar #'append-char-syntax (car result))
(append-char-syntax (cadr result)))))))
;;; Complete form
(defun slime-complete-form ()
"Complete the form at point.
This is a superset of the functionality of `slime-insert-arglist'."
(interactive)
;; Find the (possibly incomplete) form around point.
(let ((buffer-form (slime-parse-form-upto-point)))
(let ((result (slime-eval `(swank:complete-form ',buffer-form))))
(if (eq result :not-available)
(error "Could not generate completion for the form `%s'" buffer-form)
(progn
(just-one-space (if (looking-back "\\s(" (1- (point)))
0
1))
(save-excursion
(insert result)
(let ((slime-close-parens-limit 1))
(slime-close-all-parens-in-sexp)))
(save-excursion
(backward-up-list 1)
(indent-sexp)))))))
(provide 'slime-c-p-c)

1821
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-cl-indent.el Normal file
View file

File diff suppressed because it is too large Load diff

172
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-clipboard.el Normal file
View file

@ -0,0 +1,172 @@
(require 'slime)
(require 'slime-repl)
(require 'cl-lib)
(eval-when-compile
(require 'cl)) ; lexical-let
(define-slime-contrib slime-clipboard
"This add a few commands to put objects into a clipboard and to
insert textual references to those objects.
The clipboard command prefix is C-c @.
C-c @ + adds an object to the clipboard
C-c @ @ inserts a reference to an object in the clipboard
C-c @ ? displays the clipboard
This package also also binds the + key in the inspector and
debugger to add the object at point to the clipboard."
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:swank-dependencies swank-clipboard))
(define-derived-mode slime-clipboard-mode fundamental-mode
"Slime-Clipboard"
"SLIME Clipboad Mode.
\\{slime-clipboard-mode-map}")
(slime-define-keys slime-clipboard-mode-map
("g" 'slime-clipboard-redisplay)
((kbd "C-k") 'slime-clipboard-delete-entry)
("i" 'slime-clipboard-inspect))
(defvar slime-clipboard-map (make-sparse-keymap))
(slime-define-keys slime-clipboard-map
("?" 'slime-clipboard-display)
("+" 'slime-clipboard-add)
("@" 'slime-clipboard-ref))
(define-key slime-mode-map (kbd "C-c @") slime-clipboard-map)
(define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map)
(slime-define-keys slime-inspector-mode-map
("+" 'slime-clipboard-add-from-inspector))
(slime-define-keys sldb-mode-map
("+" 'slime-clipboard-add-from-sldb))
(defun slime-clipboard-add (exp package)
"Add an object to the clipboard."
(interactive (list (slime-read-from-minibuffer
"Add to clipboard (evaluated): "
(slime-sexp-at-point))
(slime-current-package)))
(slime-clipboard-add-internal `(:string ,exp ,package)))
(defun slime-clipboard-add-internal (datum)
(slime-eval-async `(swank-clipboard:add ',datum)
(lambda (result) (message "%s" result))))
(defun slime-clipboard-display ()
"Display the content of the clipboard."
(interactive)
(slime-eval-async `(swank-clipboard:entries)
#'slime-clipboard-display-entries))
(defun slime-clipboard-display-entries (entries)
(slime-with-popup-buffer ((slime-buffer-name :clipboard)
:mode 'slime-clipboard-mode)
(slime-clipboard-insert-entries entries)))
(defun slime-clipboard-insert-entries (entries)
(let ((fstring "%2s %3s %s\n"))
(insert (format fstring "Nr" "Id" "Value")
(format fstring "--" "--" "-----" ))
(save-excursion
(cl-loop for i from 0 for (ref . value) in entries do
(slime-insert-propertized `(slime-clipboard-entry ,i
slime-clipboard-ref ,ref)
(format fstring i ref value))))))
(defun slime-clipboard-redisplay ()
"Update the clipboard buffer."
(interactive)
(lexical-let ((saved (point)))
(slime-eval-async
`(swank-clipboard:entries)
(lambda (entries)
(let ((inhibit-read-only t))
(erase-buffer)
(slime-clipboard-insert-entries entries)
(when (< saved (point-max))
(goto-char saved)))))))
(defun slime-clipboard-entry-at-point ()
(or (get-text-property (point) 'slime-clipboard-entry)
(error "No clipboard entry at point")))
(defun slime-clipboard-ref-at-point ()
(or (get-text-property (point) 'slime-clipboard-ref)
(error "No clipboard ref at point")))
(defun slime-clipboard-inspect (&optional entry)
"Inspect the current clipboard entry."
(interactive (list (slime-clipboard-ref-at-point)))
(slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry))))
(defun slime-clipboard-delete-entry (&optional entry)
"Delete the current entry from the clipboard."
(interactive (list (slime-clipboard-entry-at-point)))
(slime-eval-async `(swank-clipboard:delete-entry ,entry)
(lambda (result)
(slime-clipboard-redisplay)
(message "%s" result))))
(defun slime-clipboard-ref ()
"Ask for a clipboard entry number and insert a reference to it."
(interactive)
(slime-clipboard-read-entry-number #'slime-clipboard-insert-ref))
;; insert a reference to clipboard entry ENTRY at point. The text
;; receives a special 'display property to make it look nicer. We
;; remove this property in a modification when a user tries to modify
;; he real text.
(defun slime-clipboard-insert-ref (entry)
(cl-destructuring-bind (ref . string)
(slime-eval `(swank-clipboard:entry-to-ref ,entry))
(slime-insert-propertized
`(display ,(format "#@%d%s" ref string)
modification-hooks (slime-clipboard-ref-modified)
rear-nonsticky t)
(format "(swank-clipboard::clipboard-ref %d)" ref))))
(defun slime-clipboard-ref-modified (start end)
(when (get-text-property start 'display)
(let ((inhibit-modification-hooks t))
(save-excursion
(goto-char start)
(cl-destructuring-bind (dstart dend) (slime-property-bounds 'display)
(unless (and (= start dstart) (= end dend))
(remove-list-of-text-properties
dstart dend '(display modification-hooks))))))))
;; Read a entry number.
;; Written in CPS because the display the clipboard before reading.
(defun slime-clipboard-read-entry-number (k)
(slime-eval-async
`(swank-clipboard:entries)
(slime-rcurry
(lambda (entries window-config k)
(slime-clipboard-display-entries entries)
(let ((entry (unwind-protect
(read-from-minibuffer "Entry number: " nil nil t)
(set-window-configuration window-config))))
(funcall k entry)))
(current-window-configuration)
k)))
(defun slime-clipboard-add-from-inspector ()
(interactive)
(let ((part (or (get-text-property (point) 'slime-part-number)
(error "No part at point"))))
(slime-clipboard-add-internal `(:inspector ,part))))
(defun slime-clipboard-add-from-sldb ()
(interactive)
(slime-clipboard-add-internal
`(:sldb ,(sldb-frame-number-at-point)
,(sldb-var-number-at-point))))
(provide 'slime-clipboard)

184
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-compiler-notes-tree.el Normal file
View file

@ -0,0 +1,184 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-compiler-notes-tree
"Display compiler messages in tree layout.
M-x slime-list-compiler-notes display the compiler notes in a tree
grouped by severity.
`slime-maybe-list-compiler-notes' can be used as
`slime-compilation-finished-hook'.
"
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL"))
(defun slime-maybe-list-compiler-notes (notes)
"Show the compiler notes if appropriate."
;; don't pop up a buffer if all notes are already annotated in the
;; buffer itself
(unless (cl-every #'slime-note-has-location-p notes)
(slime-list-compiler-notes notes)))
(defun slime-list-compiler-notes (notes)
"Show the compiler notes NOTES in tree view."
(interactive (list (slime-compiler-notes)))
(with-temp-message "Preparing compiler note tree..."
(slime-with-popup-buffer ((slime-buffer-name :notes)
:mode 'slime-compiler-notes-mode)
(when (null notes)
(insert "[no notes]"))
(let ((collapsed-p))
(dolist (tree (slime-compiler-notes-to-tree notes))
(when (slime-tree.collapsed-p tree) (setf collapsed-p t))
(slime-tree-insert tree "")
(insert "\n"))
(goto-char (point-min))))))
(defvar slime-tree-printer 'slime-tree-default-printer)
(defun slime-tree-for-note (note)
(make-slime-tree :item (slime-note.message note)
:plist (list 'note note)
:print-fn slime-tree-printer))
(defun slime-tree-for-severity (severity notes collapsed-p)
(make-slime-tree :item (format "%s (%d)"
(slime-severity-label severity)
(length notes))
:kids (mapcar #'slime-tree-for-note notes)
:collapsed-p collapsed-p))
(defun slime-compiler-notes-to-tree (notes)
(let* ((alist (slime-alistify notes #'slime-note.severity #'eq))
(collapsed-p (slime-length> alist 1)))
(cl-loop for (severity . notes) in alist
collect (slime-tree-for-severity severity notes
collapsed-p))))
(defvar slime-compiler-notes-mode-map)
(define-derived-mode slime-compiler-notes-mode fundamental-mode
"Compiler-Notes"
"\\<slime-compiler-notes-mode-map>\
\\{slime-compiler-notes-mode-map}
\\{slime-popup-buffer-mode-map}
"
(slime-set-truncate-lines))
(slime-define-keys slime-compiler-notes-mode-map
((kbd "RET") 'slime-compiler-notes-default-action-or-show-details)
([return] 'slime-compiler-notes-default-action-or-show-details)
([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse))
(defun slime-compiler-notes-default-action-or-show-details/mouse (event)
"Invoke the action pointed at by the mouse, or show details."
(interactive "e")
(cl-destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
(save-excursion
(goto-char pos)
(let ((fn (get-text-property (point)
'slime-compiler-notes-default-action)))
(if fn (funcall fn) (slime-compiler-notes-show-details))))))
(defun slime-compiler-notes-default-action-or-show-details ()
"Invoke the action at point, or show details."
(interactive)
(let ((fn (get-text-property (point) 'slime-compiler-notes-default-action)))
(if fn (funcall fn) (slime-compiler-notes-show-details))))
(defun slime-compiler-notes-show-details ()
(interactive)
(let* ((tree (slime-tree-at-point))
(note (plist-get (slime-tree.plist tree) 'note))
(inhibit-read-only t))
(cond ((not (slime-tree-leaf-p tree))
(slime-tree-toggle tree))
(t
(slime-show-source-location (slime-note.location note) t)))))
;;;;;; Tree Widget
(cl-defstruct (slime-tree (:conc-name slime-tree.))
item
(print-fn #'slime-tree-default-printer :type function)
(kids '() :type list)
(collapsed-p t :type boolean)
(prefix "" :type string)
(start-mark nil)
(end-mark nil)
(plist '() :type list))
(defun slime-tree-leaf-p (tree)
(not (slime-tree.kids tree)))
(defun slime-tree-default-printer (tree)
(princ (slime-tree.item tree) (current-buffer)))
(defun slime-tree-decoration (tree)
(cond ((slime-tree-leaf-p tree) "-- ")
((slime-tree.collapsed-p tree) "[+] ")
(t "-+ ")))
(defun slime-tree-insert-list (list prefix)
"Insert a list of trees."
(cl-loop for (elt . rest) on list
do (cond (rest
(insert prefix " |")
(slime-tree-insert elt (concat prefix " |"))
(insert "\n"))
(t
(insert prefix " `")
(slime-tree-insert elt (concat prefix " "))))))
(defun slime-tree-insert-decoration (tree)
(insert (slime-tree-decoration tree)))
(defun slime-tree-indent-item (start end prefix)
"Insert PREFIX at the beginning of each but the first line.
This is used for labels spanning multiple lines."
(save-excursion
(goto-char end)
(beginning-of-line)
(while (< start (point))
(insert-before-markers prefix)
(forward-line -1))))
(defun slime-tree-insert (tree prefix)
"Insert TREE prefixed with PREFIX at point."
(with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree
(let ((line-start (line-beginning-position)))
(setf start-mark (point-marker))
(slime-tree-insert-decoration tree)
(funcall print-fn tree)
(slime-tree-indent-item start-mark (point) (concat prefix " "))
(add-text-properties line-start (point) (list 'slime-tree tree))
(set-marker-insertion-type start-mark t)
(when (and kids (not collapsed-p))
(terpri (current-buffer))
(slime-tree-insert-list kids prefix))
(setf (slime-tree.prefix tree) prefix)
(setf end-mark (point-marker)))))
(defun slime-tree-at-point ()
(cond ((get-text-property (point) 'slime-tree))
(t (error "No tree at point"))))
(defun slime-tree-delete (tree)
"Delete the region for TREE."
(delete-region (slime-tree.start-mark tree)
(slime-tree.end-mark tree)))
(defun slime-tree-toggle (tree)
"Toggle the visibility of TREE's children."
(with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree
(setf collapsed-p (not collapsed-p))
(slime-tree-delete tree)
(insert-before-markers " ") ; move parent's end-mark
(backward-char 1)
(slime-tree-insert tree prefix)
(delete-char 1)
(goto-char start-mark)))
(provide 'slime-compiler-notes-tree)

183
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-editing-commands.el Normal file
View file

@ -0,0 +1,183 @@
(require 'slime)
(require 'slime-repl)
(require 'cl-lib)
(define-slime-contrib slime-editing-commands
"Editing commands without server interaction."
(:authors "Thomas F. Burdick <tfb@OCF.Berkeley.EDU>"
"Luke Gorrie <luke@synap.se>"
"Bill Clementson <billclem@gmail.com>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun)
(define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun)
(define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun)
(define-key slime-mode-map "\C-c\C-]" 'slime-close-all-parens-in-sexp)))
(defun slime-beginning-of-defun ()
(interactive)
(if (and (boundp 'slime-repl-input-start-mark)
slime-repl-input-start-mark)
(slime-repl-beginning-of-defun)
(let ((this-command 'beginning-of-defun)) ; needed for push-mark
(call-interactively 'beginning-of-defun))))
(defun slime-end-of-defun ()
(interactive)
(if (eq major-mode 'slime-repl-mode)
(slime-repl-end-of-defun)
(end-of-defun)))
(defvar slime-comment-start-regexp
"\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*"
"Regexp to match the start of a comment.")
(defun slime-beginning-of-comment ()
"Move point to beginning of comment.
If point is inside a comment move to beginning of comment and return point.
Otherwise leave point unchanged and return NIL."
(let ((boundary (point)))
(beginning-of-line)
(cond ((re-search-forward slime-comment-start-regexp boundary t)
(point))
(t (goto-char boundary)
nil))))
(defvar slime-close-parens-limit nil
"Maxmimum parens for `slime-close-all-sexp' to insert. NIL
means to insert as many parentheses as necessary to correctly
close the form.")
(defun slime-close-all-parens-in-sexp (&optional region)
"Balance parentheses of open s-expressions at point.
Insert enough right parentheses to balance unmatched left parentheses.
Delete extra left parentheses. Reformat trailing parentheses
Lisp-stylishly.
If REGION is true, operate on the region. Otherwise operate on
the top-level sexp before point."
(interactive "P")
(let ((sexp-level 0)
point)
(save-excursion
(save-restriction
(when region
(narrow-to-region (region-beginning) (region-end))
(goto-char (point-max)))
;; skip over closing parens, but not into comment
(skip-chars-backward ") \t\n")
(when (slime-beginning-of-comment)
(forward-line)
(skip-chars-forward " \t"))
(setq point (point))
;; count sexps until either '(' or comment is found at first column
(while (and (not (looking-at "^[(;]"))
(ignore-errors (backward-up-list 1) t))
(incf sexp-level))))
(when (> sexp-level 0)
;; insert correct number of right parens
(goto-char point)
(dotimes (i sexp-level) (insert ")"))
;; delete extra right parens
(setq point (point))
(skip-chars-forward " \t\n)")
(skip-chars-backward " \t\n")
(let* ((deleted-region (delete-and-extract-region point (point)))
(deleted-text (substring-no-properties deleted-region))
(prior-parens-count (cl-count ?\) deleted-text)))
;; Remember: we always insert as many parentheses as necessary
;; and only afterwards delete the superfluously-added parens.
(when slime-close-parens-limit
(let ((missing-parens (- sexp-level prior-parens-count
slime-close-parens-limit)))
(dotimes (i (max 0 missing-parens))
(delete-char -1))))))))
(defun slime-insert-balanced-comments (arg)
"Insert a set of balanced comments around the s-expression
containing the point. If this command is invoked repeatedly
\(without any other command occurring between invocations), the
comment progressively moves outward over enclosing expressions.
If invoked with a positive prefix argument, the s-expression arg
expressions out is enclosed in a set of balanced comments."
(interactive "*p")
(save-excursion
(when (eq last-command this-command)
(when (search-backward "#|" nil t)
(save-excursion
(delete-char 2)
(while (and (< (point) (point-max)) (not (looking-at " *|#")))
(forward-sexp))
(replace-match ""))))
(while (> arg 0)
(backward-char 1)
(cond ((looking-at ")") (incf arg))
((looking-at "(") (decf arg))))
(insert "#|")
(forward-sexp)
(insert "|#")))
(defun slime-remove-balanced-comments ()
"Remove a set of balanced comments enclosing point."
(interactive "*")
(save-excursion
(when (search-backward "#|" nil t)
(delete-char 2)
(while (and (< (point) (point-max)) (not (looking-at " *|#")))
(forward-sexp))
(replace-match ""))))
;; SLIME-CLOSE-PARENS-AT-POINT is obsolete:
;; It doesn't work correctly on the REPL, because there
;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to
;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and
;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the
;; way how they're expect to work (i.e. END-OF-DEFUN does not signal
;; an UNBOUND-PARENTHESES error.)
;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead.
;; (defun slime-close-parens-at-point ()
;; "Close parenthesis at point to complete the top-level-form. Simply
;; inserts ')' characters at point until `beginning-of-defun' and
;; `end-of-defun' execute without errors, or `slime-close-parens-limit'
;; is exceeded."
;; (interactive)
;; (loop for i from 1 to slime-close-parens-limit
;; until (save-excursion
;; (slime-beginning-of-defun)
;; (ignore-errors (slime-end-of-defun) t))
;; do (insert ")")))
(defun slime-reindent-defun (&optional force-text-fill)
"Reindent the current defun, or refill the current paragraph.
If point is inside a comment block, the text around point will be
treated as a paragraph and will be filled with `fill-paragraph'.
Otherwise, it will be treated as Lisp code, and the current defun
will be reindented. If the current defun has unbalanced parens,
an attempt will be made to fix it before reindenting.
When given a prefix argument, the text around point will always
be treated as a paragraph. This is useful for filling docstrings."
(interactive "P")
(save-excursion
(if (or force-text-fill (slime-beginning-of-comment))
(fill-paragraph nil)
(let ((start (progn (unless (or (and (zerop (current-column))
(eq ?\( (char-after)))
(and slime-repl-input-start-mark
(slime-repl-at-prompt-start-p)))
(slime-beginning-of-defun))
(point)))
(end (ignore-errors (slime-end-of-defun) (point))))
(unless end
(forward-paragraph)
(slime-close-all-parens-in-sexp)
(slime-end-of-defun)
(setf end (point)))
(indent-region start end nil)))))
(provide 'slime-editing-commands)

226
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-enclosing-context.el Normal file
View file

@ -0,0 +1,226 @@
(require 'slime)
(require 'slime-parse)
(require 'cl-lib)
(define-slime-contrib slime-enclosing-context
"Utilities on top of slime-parse."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-sexp-at-point (&optional n)
"Returns the sexps at point as a list of strings, otherwise nil.
\(If there are not as many sexps as N, a list with < N sexps is
returned.\)
If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
"
(interactive "p") (or n (setq n 1))
(save-excursion
(let ((result nil))
(dotimes (i n)
;; Is there an additional sexp in front of us?
(save-excursion
(unless (slime-point-moves-p (ignore-errors (forward-sexp)))
(cl-return)))
(push (slime-sexp-at-point) result)
;; Skip current sexp
(ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
(nreverse result))))
(defun slime-has-symbol-syntax-p (string)
(if (and string (not (zerop (length string))))
(member (char-syntax (aref string 0))
'(?w ?_ ?\' ?\\))))
(defun slime-beginning-of-string ()
(let* ((parser-state (slime-current-parser-state))
(inside-string-p (nth 3 parser-state))
(string-start-pos (nth 8 parser-state)))
(if inside-string-p
(goto-char string-start-pos)
(error "We're not within a string"))))
(defun slime-enclosing-form-specs (&optional max-levels)
"Return the list of ``raw form specs'' of all the forms
containing point from right to left.
As a secondary value, return a list of indices: Each index tells
for each corresponding form spec in what argument position the
user's point is.
As tertiary value, return the positions of the operators that are
contained in the returned form specs.
When MAX-LEVELS is non-nil, go up at most this many levels of
parens.
\(See SWANK::PARSE-FORM-SPEC for more information about what
exactly constitutes a ``raw form specs'')
Examples:
A return value like the following
(values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
can be interpreted as follows:
The user point is located in the 3rd argument position of a
form with the operator name \"quux\" (which starts at P1.)
This form is located in the 2nd argument position of a form
with the operator name \"bar\" (which starts at P2.)
This form again is in the 1st argument position of a form
with the operator name \"foo\" (which itself begins at P3.)
For instance, the corresponding buffer content could have looked
like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
"
(let ((level 1)
(parse-sexp-lookup-properties nil)
(initial-point (point))
(result '()) (arg-indices '()) (points '()))
;; The expensive lookup of syntax-class text properties is only
;; used for interactive balancing of #<...> in presentations; we
;; do not need them in navigating through the nested lists.
;; This speeds up this function significantly.
(ignore-errors
(save-excursion
;; Make sure we get the whole thing at point.
(if (not (slime-inside-string-p))
(slime-end-of-symbol)
(slime-beginning-of-string)
(forward-sexp))
(save-restriction
;; Don't parse more than 20000 characters before point, so we don't spend
;; too much time.
(narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
(narrow-to-region (save-excursion (beginning-of-defun) (point))
(min (1+ (point)) (point-max)))
(while (or (not max-levels)
(<= level max-levels))
(let ((arg-index 0))
;; Move to the beginning of the current sexp if not already there.
(if (or (and (char-after)
(member (char-syntax (char-after)) '(?\( ?')))
(member (char-syntax (char-before)) '(?\ ?>)))
(cl-incf arg-index))
(ignore-errors (backward-sexp 1))
(while (and (< arg-index 64)
(ignore-errors (backward-sexp 1)
(> (point) (point-min))))
(cl-incf arg-index))
(backward-up-list 1)
(when (member (char-syntax (char-after)) '(?\( ?'))
(cl-incf level)
(forward-char 1)
(let ((name (slime-symbol-at-point)))
(push (and name `(,name)) result)
(push arg-index arg-indices)
(push (point) points))
(backward-up-list 1)))))))
(cl-values
(nreverse result)
(nreverse arg-indices)
(nreverse points))))
(defvar slime-variable-binding-ops-alist
'((let &bindings &body)
(let* &bindings &body)))
(defvar slime-function-binding-ops-alist
'((flet &bindings &body)
(labels &bindings &body)
(macrolet &bindings &body)))
(defun slime-lookup-binding-op (op &optional binding-type)
(cl-labels ((lookup-in (list) (cl-assoc op list :test 'cl-equalp :key 'symbol-name)))
(cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist))
((eq binding-type :function) (lookup-in slime-function-binding-ops-alist))
(t (or (lookup-in slime-variable-binding-ops-alist)
(lookup-in slime-function-binding-ops-alist))))))
(defun slime-binding-op-p (op &optional binding-type)
(and (slime-lookup-binding-op op binding-type) t))
(defun slime-binding-op-body-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&body special-lambda-list))))
(defun slime-binding-op-bindings-pos (op)
(let ((special-lambda-list (slime-lookup-binding-op op)))
(if special-lambda-list (cl-position '&bindings special-lambda-list))))
(defun slime-enclosing-bound-names ()
"Returns all bound function names as first value, and the
points where their bindings are established as second value."
(cl-multiple-value-call #'slime-find-bound-names
(slime-enclosing-form-specs)))
(defun slime-find-bound-names (ops indices points)
(let ((binding-names) (binding-start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
(ignore-errors
(cl-loop
(down-list)
(push (slime-symbol-at-point) binding-names)
(push (save-excursion (backward-up-list) (point))
binding-start-points)
(up-list)))))
(cl-values (nreverse binding-names) (nreverse binding-start-points)))))
(defun slime-enclosing-bound-functions ()
(cl-multiple-value-call #'slime-find-bound-functions
(slime-enclosing-form-specs)))
(defun slime-find-bound-functions (ops indices points)
(let ((names) (arglists) (start-points))
(save-excursion
(cl-loop for (op . nil) in ops
for index in indices
for point in points
do (when (and (slime-binding-op-p op :function)
;; Are the bindings of OP in scope?
(>= index (slime-binding-op-body-pos op)))
(goto-char point)
(forward-sexp (slime-binding-op-bindings-pos op))
(down-list)
;; If we're at the end of the bindings, an error will
;; be signalled by the `down-list' below.
(ignore-errors
(cl-loop
(down-list)
(cl-destructuring-bind (name arglist)
(slime-parse-sexp-at-point 2)
(cl-assert (slime-has-symbol-syntax-p name))
(cl-assert arglist)
(push name names)
(push arglist arglists)
(push (save-excursion (backward-up-list) (point))
start-points))
(up-list)))))
(cl-values (nreverse names)
(nreverse arglists)
(nreverse start-points)))))
(defun slime-enclosing-bound-macros ()
(cl-multiple-value-call #'slime-find-bound-macros
(slime-enclosing-form-specs)))
(defun slime-find-bound-macros (ops indices points)
;; Kludgy!
(let ((slime-function-binding-ops-alist '((macrolet &bindings &body))))
(slime-find-bound-functions ops indices points)))
(provide 'slime-enclosing-context)

42
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-inspector.el Normal file
View file

@ -0,0 +1,42 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-fancy-inspector
"Fancy inspector for CLOS objects."
(:authors "Marco Baringer <mb@bese.it> and others")
(:license "GPL")
(:slime-dependencies slime-parse)
(:swank-dependencies swank-fancy-inspector)
(:on-load
(add-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part))
(:on-unload
(remove-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part)))
(defun slime-inspect-definition ()
"Inspect definition at point"
(interactive)
(slime-inspect (slime-definition-at-point)))
(defun slime-disassemble-definition ()
"Disassemble definition at point"
(interactive)
(slime-eval-describe `(swank:disassemble-form
,(slime-definition-at-point t))))
(defun slime-edit-inspector-part (name &optional where)
(and (eq major-mode 'slime-inspector-mode)
(cl-destructuring-bind (&optional property value)
(slime-inspector-property-at-point)
(when (eq property 'slime-part-number)
(let ((location (slime-eval `(swank:find-definition-for-thing
(swank:inspector-nth-part ,value))))
(name (format "Inspector part %s" value)))
(when (and (consp location)
(not (eq (car location) :error)))
(slime-edit-definition-cont
(list (make-slime-xref :dspec `(,name)
:location location))
name
where)))))))
(provide 'slime-fancy-inspector)

68
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy-trace.el Normal file
View file

@ -0,0 +1,68 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-fancy-trace
"Enhanced version of slime-trace capable of tracing local functions,
methods, setf functions, and other entities supported by specific
swank:swank-toggle-trace backends. Invoke via C-u C-t."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-parse))
(defun slime-trace-query (spec)
"Ask the user which function to trace; SPEC is the default.
The result is a string."
(cond ((null spec)
(slime-read-from-minibuffer "(Un)trace: "))
((stringp spec)
(slime-read-from-minibuffer "(Un)trace: " spec))
((symbolp spec) ; `slime-extract-context' can return symbols.
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
(t
(slime-dcase spec
((setf n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:defun n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
((:defgeneric n)
(let* ((name (prin1-to-string n))
(answer (slime-read-from-minibuffer "(Un)trace: " name)))
(cond ((and (string= name answer)
(y-or-n-p (concat "(Un)trace also all "
"methods implementing "
name "? ")))
(prin1-to-string `(:defgeneric ,n)))
(t
answer))))
((:defmethod &rest _)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:call caller callee)
(let* ((callerstr (prin1-to-string caller))
(calleestr (prin1-to-string callee))
(answer (slime-read-from-minibuffer "(Un)trace: "
calleestr)))
(cond ((and (string= calleestr answer)
(y-or-n-p (concat "(Un)trace only when " calleestr
" is called by " callerstr "? ")))
(prin1-to-string `(:call ,caller ,callee)))
(t
answer))))
(((:labels :flet) &rest _)
(slime-read-from-minibuffer "(Un)trace local function: "
(prin1-to-string spec)))
(t (error "Don't know how to trace the spec %S" spec))))))
(defun slime-toggle-fancy-trace (&optional using-context-p)
"Toggle trace."
(interactive "P")
(let* ((spec (if using-context-p
(slime-extract-context)
(slime-symbol-at-point)))
(spec (slime-trace-query spec)))
(message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))
;; override slime-toggle-trace-fdefinition
(define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace)
(provide 'slime-fancy-trace)

38
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fancy.el Normal file
View file

@ -0,0 +1,38 @@
(require 'slime)
(define-slime-contrib slime-fancy
"Make SLIME fancy."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-repl
slime-autodoc
slime-c-p-c
slime-editing-commands
slime-fancy-inspector
slime-fancy-trace
slime-fuzzy
slime-mdot-fu
slime-macrostep
slime-presentations
slime-scratch
slime-references
slime-package-fu
slime-fontifying-fu
slime-trace-dialog)
(:on-load
(slime-trace-dialog-init)
(slime-repl-init)
(slime-autodoc-init)
(slime-c-p-c-init)
(slime-editing-commands-init)
(slime-fancy-inspector-init)
(slime-fancy-trace-init)
(slime-fuzzy-init)
(slime-presentations-init)
(slime-scratch-init)
(slime-references-init)
(slime-package-fu-init)
(slime-fontifying-fu-init)))
(provide 'slime-fancy)

231
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fontifying-fu.el Normal file
View file

@ -0,0 +1,231 @@
(require 'slime)
(require 'slime-parse)
(require 'slime-autodoc)
(require 'font-lock)
(require 'cl-lib)
;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros.
;;; Fontify CHECK-FOO like CHECK-TYPE.
(defvar slime-additional-font-lock-keywords
'(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)
("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
;;;; Specially fontify forms suppressed by a reader conditional.
(defcustom slime-highlight-suppressed-forms t
"Display forms disabled by reader conditionals as comments."
:type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
:group 'slime-mode)
(define-slime-contrib slime-fontifying-fu
"Additional fontification tweaks:
Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros.
Fontify CHECK-FOO like CHECK-TYPE."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:on-load
(font-lock-add-keywords
'lisp-mode slime-additional-font-lock-keywords)
(when slime-highlight-suppressed-forms
(slime-activate-font-lock-magic)))
(:on-unload
;; FIXME: remove `slime-search-suppressed-forms', and remove the
;; extend-region hook.
(font-lock-remove-keywords
'lisp-mode slime-additional-font-lock-keywords)))
(defface slime-reader-conditional-face
'((t (:inherit font-lock-comment-face)))
"Face for compiler notes while selected."
:group 'slime-mode-faces)
(defvar slime-search-suppressed-forms-match-data (list nil nil))
(defun slime-search-suppressed-forms-internal (limit)
(when (search-forward-regexp slime-reader-conditionals-regexp limit t)
(let ((start (match-beginning 0)) ; save match data
(state (slime-current-parser-state)))
(if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
(slime-search-suppressed-forms-internal limit)
(let* ((char (char-before))
(expr (read (current-buffer)))
(val (slime-eval-feature-expression expr)))
(when (<= (point) limit)
(if (or (and (eq char ?+) (not val))
(and (eq char ?-) val))
;; If `slime-extend-region-for-font-lock' did not
;; fully extend the region, the assertion below may
;; fail. This should only happen on XEmacs and older
;; versions of GNU Emacs.
(ignore-errors
(forward-sexp) (backward-sexp)
;; Try to suppress as far as possible.
(slime-forward-sexp)
(cl-assert (<= (point) limit))
(let ((md (match-data nil slime-search-suppressed-forms-match-data)))
(setf (cl-first md) start)
(setf (cl-second md) (point))
(set-match-data md)
t))
(slime-search-suppressed-forms-internal limit))))))))
(defun slime-search-suppressed-forms (limit)
"Find reader conditionalized forms where the test is false."
(when (and slime-highlight-suppressed-forms
(slime-connected-p))
(let ((result 'retry))
(while (and (eq result 'retry) (<= (point) limit))
(condition-case condition
(setq result (slime-search-suppressed-forms-internal limit))
(end-of-file ; e.g. #+(
(setq result nil))
;; We found a reader conditional we couldn't process for
;; some reason; however, there may still be other reader
;; conditionals before `limit'.
(invalid-read-syntax ; e.g. #+#.foo
(setq result 'retry))
(scan-error ; e.g. #+nil (foo ...
(setq result 'retry))
(slime-incorrect-feature-expression ; e.g. #+(not foo bar)
(setq result 'retry))
(slime-unknown-feature-expression ; e.g. #+(foo)
(setq result 'retry))
(error
(setq result nil)
(slime-display-warning
(concat "Caught error during fontification while searching for forms\n"
"that are suppressed by reader-conditionals. The error was: %S.")
condition))))
result)))
(defun slime-search-directly-preceding-reader-conditional ()
"Search for a directly preceding reader conditional. Return its
position, or nil."
;;; We search for a preceding reader conditional. Then we check that
;;; between the reader conditional and the point where we started is
;;; no other intervening sexp, and we check that the reader
;;; conditional is at the same nesting level.
(condition-case nil
(let* ((orig-pt (point))
(reader-conditional-pt
(search-backward-regexp slime-reader-conditionals-regexp
;; We restrict the search to the
;; beginning of the /previous/ defun.
(save-excursion
(beginning-of-defun)
(point))
t)))
(when reader-conditional-pt
(let* ((parser-state
(parse-partial-sexp
(progn (goto-char (+ reader-conditional-pt 2))
(forward-sexp) ; skip feature expr.
(point))
orig-pt))
(paren-depth (car parser-state))
(last-sexp-pt (cl-caddr parser-state)))
(if (and paren-depth
(not (cl-plusp paren-depth)) ; no '(' in between?
(not last-sexp-pt)) ; no complete sexp in between?
reader-conditional-pt
nil))))
(scan-error nil))) ; improper feature expression
;;; We'll push this onto `font-lock-extend-region-functions'. In past,
;;; we didn't do so which made our reader-conditional font-lock magic
;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
;;; worked quite non-deterministic in general.)
;;;
;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
;;;
;;; We make sure that `font-lock-beg' and `font-lock-end' always point
;;; to the beginning or end of a toplevel form. So we never miss a
;;; reader-conditional, or point in mid of one.
(defvar font-lock-beg) ; shoosh compiler
(defvar font-lock-end)
(defun slime-extend-region-for-font-lock ()
(when slime-highlight-suppressed-forms
(condition-case c
(let (changedp)
(cl-multiple-value-setq (changedp font-lock-beg font-lock-end)
(slime-compute-region-for-font-lock font-lock-beg font-lock-end))
changedp)
(error
(slime-display-warning
(concat "Caught error when trying to extend the region for fontification.\n"
"The error was: %S\n"
"Further: font-lock-beg=%d, font-lock-end=%d.")
c font-lock-beg font-lock-end)))))
(defun slime-beginning-of-tlf ()
(let ((pos (syntax-ppss-toplevel-pos (slime-current-parser-state))))
(if pos (goto-char pos))))
(defun slime-compute-region-for-font-lock (orig-beg orig-end)
(let ((beg orig-beg)
(end orig-end))
(goto-char beg)
(inline (slime-beginning-of-tlf))
(cl-assert (not (cl-plusp (nth 0 (slime-current-parser-state)))))
(setq beg (let ((pt (point)))
(cond ((> (- beg pt) 20000) beg)
((slime-search-directly-preceding-reader-conditional))
(t pt))))
(goto-char end)
(while (search-backward-regexp slime-reader-conditionals-regexp beg t)
(setq end (max end (save-excursion
(ignore-errors (slime-forward-reader-conditional))
(point)))))
(cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
(defun slime-activate-font-lock-magic ()
(if (featurep 'xemacs)
(let ((pattern `((slime-search-suppressed-forms
(0 slime-reader-conditional-face t)))))
(dolist (sym '(lisp-font-lock-keywords
lisp-font-lock-keywords-1
lisp-font-lock-keywords-2))
(set sym (append (symbol-value sym) pattern))))
(font-lock-add-keywords
'lisp-mode
`((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
(add-hook 'lisp-mode-hook
#'(lambda ()
(add-hook 'font-lock-extend-region-functions
'slime-extend-region-for-font-lock t t)))))
(let ((byte-compile-warnings '()))
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (byte-code-function-p (symbol-function sym))
(byte-compile sym)))
(t (error "%S is not fbound" sym))))
'(slime-extend-region-for-font-lock
slime-compute-region-for-font-lock
slime-search-directly-preceding-reader-conditional
slime-search-suppressed-forms
slime-beginning-of-tlf)))
(cl-defun slime-initialize-lisp-buffer-for-test-suite
(&key (font-lock-magic t) (autodoc t))
(let ((hook lisp-mode-hook))
(unwind-protect
(progn
(set (make-local-variable 'slime-highlight-suppressed-forms)
font-lock-magic)
(setq lisp-mode-hook nil)
(lisp-mode)
(slime-mode 1)
(when (boundp 'slime-autodoc-mode)
(if autodoc
(slime-autodoc-mode 1)
(slime-autodoc-mode -1))))
(setq lisp-mode-hook hook))))
(provide 'slime-fontifying-fu)

604
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-fuzzy.el Normal file
View file

@ -0,0 +1,604 @@
(require 'slime)
(require 'slime-repl)
(require 'slime-c-p-c)
(require 'cl-lib)
(define-slime-contrib slime-fuzzy
"Fuzzy symbol completion."
(:authors "Brian Downing <bdowning@lavos.net>"
"Tobias C. Rittweiler <tcr@freebits.de>"
"Attila Lendvai <attila.lendvai@gmail.com>")
(:license "GPL")
(:swank-dependencies swank-fuzzy)
(:on-load
(define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)
(when (featurep 'slime-repl)
(define-key slime-repl-mode-map "\C-c\M-i"
'slime-fuzzy-complete-symbol))))
(defcustom slime-fuzzy-completion-in-place t
"When non-NIL the fuzzy symbol completion is done in place as
opposed to moving the point to the completion buffer."
:group 'slime-mode
:type 'boolean)
(defcustom slime-fuzzy-completion-limit 300
"Only return and present this many symbols from swank."
:group 'slime-mode
:type 'integer)
(defcustom slime-fuzzy-completion-time-limit-in-msec 1500
"Limit the time spent (given in msec) in swank while gathering
completions."
:group 'slime-mode
:type 'integer)
(defcustom slime-when-complete-filename-expand nil
"Use comint-replace-by-expanded-filename instead of
comint-filename-completion to complete file names"
:group 'slime-mode
:type 'boolean)
(defvar slime-fuzzy-target-buffer nil
"The buffer that is the target of the completion activities.")
(defvar slime-fuzzy-saved-window-configuration nil
"The saved window configuration before the fuzzy completion
buffer popped up.")
(defvar slime-fuzzy-start nil
"The beginning of the completion slot in the target buffer.
This is a non-advancing marker.")
(defvar slime-fuzzy-end nil
"The end of the completion slot in the target buffer.
This is an advancing marker.")
(defvar slime-fuzzy-original-text nil
"The original text that was in the completion slot in the
target buffer. This is what is put back if completion is
aborted.")
(defvar slime-fuzzy-text nil
"The text that is currently in the completion slot in the
target buffer. If this ever doesn't match, the target buffer has
been modified and we abort without touching it.")
(defvar slime-fuzzy-first nil
"The position of the first completion in the completions buffer.
The descriptive text and headers are above this.")
(defvar slime-fuzzy-last nil
"The position of the last completion in the completions buffer.
If the time limit has exhausted during generation possible completion
choices inside SWANK, an indication is printed below this.")
(defvar slime-fuzzy-current-completion nil
"The current completion object. If this is the same before and
after point moves in the completions buffer, the text is not
replaced in the target for efficiency.")
(defvar slime-fuzzy-current-completion-overlay nil
"The overlay representing the current completion in the completion
buffer. This is used to hightlight the text.")
;;;;;;; slime-target-buffer-fuzzy-completions-mode
;; NOTE: this mode has to be able to override key mappings in slime-mode
(defvar slime-target-buffer-fuzzy-completions-map
(let ((map (make-sparse-keymap)))
(cl-labels ((def (keys command)
(unless (listp keys)
(setq keys (list keys)))
(dolist (key keys)
(define-key map key command))))
(def `([remap keyboard-quit]
,(kbd "C-g"))
'slime-fuzzy-abort)
(def `([remap slime-fuzzy-indent-and-complete-symbol]
[remap slime-indent-and-complete-symbol]
,(kbd "<tab>"))
'slime-fuzzy-select-or-update-completions)
(def `([remap previous-line]
,(kbd "<up>"))
'slime-fuzzy-prev)
(def `([remap next-line]
,(kbd "<down>"))
'slime-fuzzy-next)
(def `([remap isearch-forward]
,(kbd "C-s"))
'slime-fuzzy-continue-isearch-in-fuzzy-buffer)
;; some unconditional direct bindings
(def (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]")
'slime-fuzzy-select-and-process-event-in-target-buffer))
map)
"Keymap for slime-target-buffer-fuzzy-completions-mode.
This will override the key bindings in the target buffer
temporarily during completion.")
;; Make sure slime-fuzzy-target-buffer-completions-mode's map is
;; before everything else.
(setf minor-mode-map-alist
(cl-stable-sort minor-mode-map-alist
(lambda (a b)
(eq a 'slime-fuzzy-target-buffer-completions-mode))
:key #'car))
(defun slime-fuzzy-continue-isearch-in-fuzzy-buffer ()
(interactive)
(select-window (get-buffer-window (slime-get-fuzzy-buffer)))
(call-interactively 'isearch-forward))
(define-minor-mode slime-fuzzy-target-buffer-completions-mode
"This minor mode is intented to override key bindings during
fuzzy completions in the target buffer. Most of the bindings will
do an implicit select in the completion window and let the
keypress be processed in the target buffer."
nil
nil
slime-target-buffer-fuzzy-completions-map)
(add-to-list 'minor-mode-alist
'(slime-fuzzy-target-buffer-completions-mode
" Fuzzy Target Buffer Completions"))
(defvar slime-fuzzy-completions-map
(let ((map (make-sparse-keymap)))
(cl-labels ((def (keys command)
(unless (listp keys)
(setq keys (list keys)))
(dolist (key keys)
(define-key map key command))))
(def `([remap keyboard-quit]
"q"
,(kbd "C-g"))
'slime-fuzzy-abort)
(def `([remap previous-line]
"p"
"\M-p"
,(kbd "<up>"))
'slime-fuzzy-prev)
(def `([remap next-line]
"n"
"\M-n"
,(kbd "<down>"))
'slime-fuzzy-next)
(def "\d" 'scroll-down)
(def `([remap slime-fuzzy-indent-and-complete-symbol]
[remap slime-indent-and-complete-symbol]
,(kbd "<tab>"))
'slime-fuzzy-select)
(def (kbd "<mouse-2>") 'slime-fuzzy-select/mouse)
(def `(,(kbd "RET")
,(kbd "<SPC>"))
'slime-fuzzy-select))
map)
"Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
(define-derived-mode slime-fuzzy-completions-mode
fundamental-mode "Fuzzy Completions"
"Major mode for presenting fuzzy completion results.
When you run `slime-fuzzy-complete-symbol', the symbol token at
point is completed using the Fuzzy Completion algorithm; this
means that the token is taken as a sequence of characters and all
the various possibilities that this sequence could meaningfully
represent are offered as selectable choices, sorted by how well
they deem to be a match for the token. (For instance, the first
choice of completing on \"mvb\" would be \"multiple-value-bind\".)
Therefore, a new buffer (*Fuzzy Completions*) will pop up that
contains the different completion choices. Simultaneously, a
special minor-mode will be temporarily enabled in the original
buffer where you initiated fuzzy completion (also called the
``target buffer'') in order to navigate through the *Fuzzy
Completions* buffer without leaving.
With focus in *Fuzzy Completions*:
Type `n' and `p' (`UP', `DOWN') to navigate between completions.
Type `RET' or `TAB' to select the completion near point.
Type `q' to abort.
With focus in the target buffer:
Type `UP' and `DOWN' to navigate between completions.
Type a character that does not constitute a symbol name
to insert the current choice and then that character (`(', `)',
`SPACE', `RET'.) Use `TAB' to simply insert the current choice.
Use C-g to abort.
Alternatively, you can click <mouse-2> on a completion to select it.
Complete listing of keybindings within the target buffer:
\\<slime-target-buffer-fuzzy-completions-map>\
\\{slime-target-buffer-fuzzy-completions-map}
Complete listing of keybindings with *Fuzzy Completions*:
\\<slime-fuzzy-completions-map>\
\\{slime-fuzzy-completions-map}"
(use-local-map slime-fuzzy-completions-map)
(set (make-local-variable 'slime-fuzzy-current-completion-overlay)
(make-overlay (point) (point) nil t nil)))
(defun slime-fuzzy-completions (prefix &optional default-package)
"Get the list of sorted completion objects from completing
`prefix' in `package' from the connected Lisp."
(let ((prefix (cl-etypecase prefix
(symbol (symbol-name prefix))
(string prefix))))
(slime-eval `(swank:fuzzy-completions ,prefix
,(or default-package
(slime-current-package))
:limit ,slime-fuzzy-completion-limit
:time-limit-in-msec
,slime-fuzzy-completion-time-limit-in-msec))))
(defun slime-fuzzy-selected (prefix completion)
"Tell the connected Lisp that the user selected completion
`completion' as the completion for `prefix'."
(let ((no-properties (copy-sequence prefix)))
(set-text-properties 0 (length no-properties) nil no-properties)
(slime-eval `(swank:fuzzy-completion-selected ,no-properties
',completion))))
(defun slime-fuzzy-indent-and-complete-symbol ()
"Indent the current line and perform fuzzy symbol completion. First
indent the line. If indenting doesn't move point, complete the
symbol. If there's no symbol at the point, show the arglist for the
most recently enclosed macro or function."
(interactive)
(let ((pos (point)))
(unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
(lisp-indent-line))
(when (= pos (point))
(cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
(slime-fuzzy-complete-symbol))
((memq (char-before) '(?\t ?\ ))
(slime-echo-arglist))))))
(cl-defun slime-fuzzy-complete-symbol ()
"Fuzzily completes the abbreviation at point into a symbol."
(interactive)
(when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
(cl-return-from slime-fuzzy-complete-symbol
;; don't add space after completion
(let ((comint-completion-addsuffix '("/" . "")))
(if slime-when-complete-filename-expand
(comint-replace-by-expanded-filename)
;; FIXME: use `comint-filename-completion' when dropping emacs23
(funcall (if (>= emacs-major-version 24)
'comint-filename-completion
'comint-dynamic-complete-as-filename))))))
(let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos)))
(prefix (buffer-substring-no-properties beg end)))
(cl-destructuring-bind (completion-set interrupted-p)
(slime-fuzzy-completions prefix)
(if (null completion-set)
(progn (slime-minibuffer-respecting-message
"Can't find completion for \"%s\"" prefix)
(ding)
(slime-fuzzy-done))
(goto-char end)
(cond ((slime-length= completion-set 1)
;; insert completed string
(insert-and-inherit (caar completion-set))
(delete-region beg end)
(goto-char (+ beg (length (caar completion-set))))
(slime-minibuffer-respecting-message "Sole completion")
(slime-fuzzy-done))
;; Incomplete
(t
(slime-fuzzy-choices-buffer completion-set interrupted-p
beg end)
(slime-minibuffer-respecting-message
"Complete but not unique")))))))
(defun slime-get-fuzzy-buffer ()
(get-buffer-create "*Fuzzy Completions*"))
(defvar slime-fuzzy-explanation
"For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
Flags: boundp fboundp generic-function class macro special-operator package
\n"
"The explanation that gets inserted at the beginning of the
*Fuzzy Completions* buffer.")
(defun slime-fuzzy-insert-completion-choice (completion max-length)
"Inserts the completion object `completion' as a formatted
completion choice into the current buffer, and mark it with the
proper text properties."
(cl-destructuring-bind (symbol-name score chunks classification-string)
completion
(let ((start (point))
(end))
(insert symbol-name)
(setq end (point))
(dolist (chunk chunks)
(put-text-property (+ start (cl-first chunk))
(+ start (cl-first chunk)
(length (cl-second chunk)))
'face 'bold))
(put-text-property start (point) 'mouse-face 'highlight)
(dotimes (i (- max-length (- end start)))
(insert " "))
(insert (format " %s %s\n"
classification-string
score))
(put-text-property start (point) 'completion completion))))
(defun slime-fuzzy-insert (text)
"Inserts `text' into the target buffer in the completion slot.
If the buffer has been modified in the meantime, abort the
completion process. Otherwise, update all completion variables
so that the new text is present."
(with-current-buffer slime-fuzzy-target-buffer
(cond
((not (string-equal slime-fuzzy-text
(buffer-substring slime-fuzzy-start
slime-fuzzy-end)))
(slime-fuzzy-done)
(beep)
(message "Target buffer has been modified!"))
(t
(goto-char slime-fuzzy-start)
(delete-region slime-fuzzy-start slime-fuzzy-end)
(insert-and-inherit text)
(setq slime-fuzzy-text text)
(goto-char slime-fuzzy-end)))))
(defun slime-minibuffer-p (buffer)
(if (featurep 'xemacs)
(eq buffer (window-buffer (minibuffer-window)))
(minibufferp buffer)))
(defun slime-fuzzy-choices-buffer (completions interrupted-p start end)
"Creates (if neccessary), populates, and pops up the *Fuzzy
Completions* buffer with the completions from `completions' and
the completion slot in the current buffer bounded by `start' and
`end'. This saves the window configuration before popping the
buffer so that it can possibly be restored when the user is
done."
(let ((new-completion-buffer (not slime-fuzzy-target-buffer))
(connection (slime-connection)))
(when new-completion-buffer
(setq slime-fuzzy-saved-window-configuration
(current-window-configuration)))
(slime-fuzzy-enable-target-buffer-completions-mode)
(setq slime-fuzzy-target-buffer (current-buffer))
(setq slime-fuzzy-start (move-marker (make-marker) start))
(setq slime-fuzzy-end (move-marker (make-marker) end))
(set-marker-insertion-type slime-fuzzy-end t)
(setq slime-fuzzy-original-text (buffer-substring start end))
(setq slime-fuzzy-text slime-fuzzy-original-text)
(slime-fuzzy-fill-completions-buffer completions interrupted-p)
(pop-to-buffer (slime-get-fuzzy-buffer))
(slime-fuzzy-next)
(setq slime-buffer-connection connection)
(when new-completion-buffer
;; Hook to nullify window-config restoration if the user changes
;; the window configuration himself.
(when (boundp 'window-configuration-change-hook)
(add-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change))
(add-hook 'kill-buffer-hook 'slime-fuzzy-abort 'append t)
(set (make-local-variable 'cursor-type) nil)
(setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
(when slime-fuzzy-completion-in-place
;; switch back to the original buffer
(if (slime-minibuffer-p slime-fuzzy-target-buffer)
(select-window (minibuffer-window))
(switch-to-buffer-other-window slime-fuzzy-target-buffer)))))
(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
"Erases and fills the completion buffer with the given completions."
(with-current-buffer (slime-get-fuzzy-buffer)
(setq buffer-read-only nil)
(erase-buffer)
(slime-fuzzy-completions-mode)
(insert slime-fuzzy-explanation)
(let ((max-length 12))
(dolist (completion completions)
(setf max-length (max max-length (length (cl-first completion)))))
(insert "Completion:")
(dotimes (i (- max-length 10)) (insert " "))
;; Flags: Score:
;; ... ------- --------
;; bfgctmsp
(let* ((example-classification-string (cl-fourth (cl-first completions)))
(classification-length (length example-classification-string))
(spaces (- classification-length (length "Flags:"))))
(insert "Flags:")
(dotimes (i spaces) (insert " "))
(insert " Score:\n")
(dotimes (i max-length) (insert "-"))
(insert " ")
(dotimes (i classification-length) (insert "-"))
(insert " --------\n")
(setq slime-fuzzy-first (point)))
(dolist (completion completions)
(setq slime-fuzzy-last (point)) ; will eventually become the last entry
(slime-fuzzy-insert-completion-choice completion max-length))
(when interrupted-p
(insert "...\n")
(insert "[Interrupted: time limit exhausted]"))
(setq buffer-read-only t))
(setq slime-fuzzy-current-completion
(caar completions))
(goto-char 0)))
(defun slime-fuzzy-enable-target-buffer-completions-mode ()
"Store the target buffer's local map, so that we can restore it."
(unless slime-fuzzy-target-buffer-completions-mode
; (slime-log-event "Enabling target buffer completions mode")
(slime-fuzzy-target-buffer-completions-mode 1)))
(defun slime-fuzzy-disable-target-buffer-completions-mode ()
"Restores the target buffer's local map when completion is finished."
(when slime-fuzzy-target-buffer-completions-mode
; (slime-log-event "Disabling target buffer completions mode")
(slime-fuzzy-target-buffer-completions-mode 0)))
(defun slime-fuzzy-insert-from-point ()
"Inserts the completion that is under point in the completions
buffer into the target buffer. If the completion in question had
already been inserted, it does nothing."
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((current-completion (get-text-property (point) 'completion)))
(when (and current-completion
(not (eq slime-fuzzy-current-completion
current-completion)))
(slime-fuzzy-insert
(cl-first (get-text-property (point) 'completion)))
(setq slime-fuzzy-current-completion
current-completion)))))
(defun slime-fuzzy-post-command-hook ()
"The post-command-hook for the *Fuzzy Completions* buffer.
This makes sure the completion slot in the target buffer matches
the completion that point is on in the completions buffer."
(condition-case err
(when slime-fuzzy-target-buffer
(slime-fuzzy-insert-from-point))
(error
;; Because this is called on the post-command-hook, we mustn't let
;; errors propagate.
(message "Error in slime-fuzzy-post-command-hook: %S" err))))
(defun slime-fuzzy-next ()
"Moves point directly to the next completion in the completions
buffer."
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((point (next-single-char-property-change
(point) 'completion nil slime-fuzzy-last)))
(set-window-point (get-buffer-window (current-buffer)) point)
(goto-char point))
(slime-fuzzy-highlight-current-completion)))
(defun slime-fuzzy-prev ()
"Moves point directly to the previous completion in the
completions buffer."
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((point (previous-single-char-property-change
(point)
'completion nil slime-fuzzy-first)))
(set-window-point (get-buffer-window (current-buffer)) point)
(goto-char point))
(slime-fuzzy-highlight-current-completion)))
(defun slime-fuzzy-highlight-current-completion ()
"Highlights the current completion,
so that the user can see it on the screen."
(let ((pos (point)))
(when (overlayp slime-fuzzy-current-completion-overlay)
(move-overlay slime-fuzzy-current-completion-overlay
(point) (1- (search-forward " ")))
(overlay-put slime-fuzzy-current-completion-overlay
'face 'secondary-selection))
(goto-char pos)))
(defun slime-fuzzy-abort ()
"Aborts the completion process, setting the completions slot in
the target buffer back to its original contents."
(interactive)
(when slime-fuzzy-target-buffer
(slime-fuzzy-done)))
(defun slime-fuzzy-select ()
"Selects the current completion, making sure that it is inserted
into the target buffer. This tells the connected Lisp what completion
was selected."
(interactive)
(when slime-fuzzy-target-buffer
(with-current-buffer (slime-get-fuzzy-buffer)
(let ((completion (get-text-property (point) 'completion)))
(when completion
(slime-fuzzy-insert (cl-first completion))
(slime-fuzzy-selected slime-fuzzy-original-text
completion)
(slime-fuzzy-done))))))
(defun slime-fuzzy-select-or-update-completions ()
"If there were no changes since the last time fuzzy completion was started
this function will select the current completion.
Otherwise refreshes the completion list based on the changes made."
(interactive)
; (slime-log-event "Selecting or updating completions")
(if (string-equal slime-fuzzy-original-text
(buffer-substring slime-fuzzy-start
slime-fuzzy-end))
(slime-fuzzy-select)
(slime-fuzzy-complete-symbol)))
(defun slime-fuzzy-process-event-in-completions-buffer ()
"Simply processes the event in the target buffer"
(interactive)
(with-current-buffer (slime-get-fuzzy-buffer)
(push last-input-event unread-command-events)))
(defun slime-fuzzy-select-and-process-event-in-target-buffer ()
"Selects the current completion, making sure that it is inserted
into the target buffer and processes the event in the target buffer."
(interactive)
; (slime-log-event "Selecting and processing event in target buffer")
(when slime-fuzzy-target-buffer
(let ((buff slime-fuzzy-target-buffer))
(slime-fuzzy-select)
(with-current-buffer buff
(slime-fuzzy-disable-target-buffer-completions-mode)
(push last-input-event unread-command-events)))))
(defun slime-fuzzy-select/mouse (event)
"Handle a mouse-2 click on a completion choice as if point were
on the completion choice and the slime-fuzzy-select command was
run."
(interactive "e")
(with-current-buffer (window-buffer (posn-window (event-end event)))
(save-excursion
(goto-char (posn-point (event-end event)))
(when (get-text-property (point) 'mouse-face)
(slime-fuzzy-insert-from-point)
(slime-fuzzy-select)))))
(defun slime-fuzzy-done ()
"Cleans up after the completion process. This removes all hooks,
and attempts to restore the window configuration. If this fails,
it just burys the completions buffer and leaves the window
configuration alone."
(when slime-fuzzy-target-buffer
(set-buffer slime-fuzzy-target-buffer)
(slime-fuzzy-disable-target-buffer-completions-mode)
(if (slime-fuzzy-maybe-restore-window-configuration)
(bury-buffer (slime-get-fuzzy-buffer))
;; We couldn't restore the windows, so just bury the fuzzy
;; completions buffer and let something else fill it in.
(pop-to-buffer (slime-get-fuzzy-buffer))
(bury-buffer))
(if (slime-minibuffer-p slime-fuzzy-target-buffer)
(select-window (minibuffer-window))
(pop-to-buffer slime-fuzzy-target-buffer))
(goto-char slime-fuzzy-end)
(setq slime-fuzzy-target-buffer nil)
(remove-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change)))
(defun slime-fuzzy-maybe-restore-window-configuration ()
"Restores the saved window configuration if it has not been
nullified."
(when (boundp 'window-configuration-change-hook)
(remove-hook 'window-configuration-change-hook
'slime-fuzzy-window-configuration-change))
(if (not slime-fuzzy-saved-window-configuration)
nil
(set-window-configuration slime-fuzzy-saved-window-configuration)
(setq slime-fuzzy-saved-window-configuration nil)
t))
(defun slime-fuzzy-window-configuration-change ()
"Called on window-configuration-change-hook. Since the window
configuration was changed, we nullify our saved configuration."
(setq slime-fuzzy-saved-window-configuration nil))
(provide 'slime-fuzzy)

81
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-highlight-edits.el Normal file
View file

@ -0,0 +1,81 @@
(require 'slime)
(require 'slime-parse)
(define-slime-contrib slime-highlight-edits
"Highlight edited, i.e. not yet compiled, code."
(:authors "William Bland <doctorbill.news@gmail.com>")
(:license "GPL")
(:on-load (add-hook 'slime-mode-hook 'slime-activate-highlight-edits))
(:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits)))
(defun slime-activate-highlight-edits ()
(slime-highlight-edits-mode 1))
(defface slime-highlight-edits-face
`((((class color) (background light))
(:background "lightgray"))
(((class color) (background dark))
(:background "dimgray"))
(t (:background "yellow")))
"Face for displaying edit but not compiled code."
:group 'slime-mode-faces)
(define-minor-mode slime-highlight-edits-mode
"Minor mode to highlight not-yet-compiled code." nil)
(add-hook 'slime-highlight-edits-mode-on-hook
'slime-highlight-edits-init-buffer)
(add-hook 'slime-highlight-edits-mode-off-hook
'slime-highlight-edits-reset-buffer)
(defun slime-highlight-edits-init-buffer ()
(make-local-variable 'after-change-functions)
(add-to-list 'after-change-functions
'slime-highlight-edits)
(add-to-list 'slime-before-compile-functions
'slime-highlight-edits-compile-hook))
(defun slime-highlight-edits-reset-buffer ()
(setq after-change-functions
(remove 'slime-highlight-edits after-change-functions))
(slime-remove-edits (point-min) (point-max)))
;; FIXME: what's the LEN arg for?
(defun slime-highlight-edits (beg end &optional len)
(save-match-data
(when (and (slime-connected-p)
(not (slime-inside-comment-p))
(not (slime-only-whitespace-p beg end)))
(let ((overlay (make-overlay beg end)))
(overlay-put overlay 'face 'slime-highlight-edits-face)
(overlay-put overlay 'slime-edit t)))))
(defun slime-remove-edits (start end)
"Delete the existing Slime edit hilights in the current buffer."
(save-excursion
(goto-char start)
(while (< (point) end)
(dolist (o (overlays-at (point)))
(when (overlay-get o 'slime-edit)
(delete-overlay o)))
(goto-char (next-overlay-change (point))))))
(defun slime-highlight-edits-compile-hook (start end)
(when slime-highlight-edits-mode
(let ((start (save-excursion (goto-char start)
(skip-chars-backward " \t\n\r")
(point)))
(end (save-excursion (goto-char end)
(skip-chars-forward " \t\n\r")
(point))))
(slime-remove-edits start end))))
(defun slime-only-whitespace-p (beg end)
"Contains the region from BEG to END only whitespace?"
(save-excursion
(goto-char beg)
(skip-chars-forward " \n\t\r" end)
(<= end (point))))
(provide 'slime-highlight-edits)

48
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-hyperdoc.el Normal file
View file

@ -0,0 +1,48 @@
(require 'slime)
(require 'url-http)
(require 'browse-url)
(eval-when-compile (require 'cl)) ; lexical-let
(defvar slime-old-documentation-lookup-function
slime-documentation-lookup-function)
(define-slime-contrib slime-hyperdoc
"Extensible C-c C-d h."
(:authors "Tobias C Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:swank-dependencies swank-hyperdoc)
(:on-load
(setq slime-documentation-lookup-function 'slime-hyperdoc-lookup))
(:on-unload
(setq slime-documentation-lookup-function
slime-old-documentation-lookup-function)))
;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour.
(defun slime-hyperdoc-lookup-rpc (symbol-name)
(slime-eval-async `(swank:hyperdoc ,symbol-name)
(lexical-let ((symbol-name symbol-name))
#'(lambda (result)
(slime-log-event result)
(cl-loop with foundp = nil
for (doc-type . url) in result do
(when (and url (stringp url)
(let ((url-show-status nil))
(url-http-file-exists-p url)))
(message "Visiting documentation for %s `%s'..."
(substring (symbol-name doc-type) 1)
symbol-name)
(browse-url url)
(setq foundp t))
finally
(unless foundp
(error "Could not find documentation for `%s'."
symbol-name)))))))
(defun slime-hyperdoc-lookup (symbol-name)
(interactive (list (slime-read-symbol-name "Symbol: ")))
(if (memq :hyperdoc (slime-lisp-features))
(slime-hyperdoc-lookup-rpc symbol-name)
(slime-hyperspec-lookup symbol-name)))
(provide 'slime-hyperdoc)

31
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-indentation.el Normal file
View file

@ -0,0 +1,31 @@
(require 'slime)
(require 'slime-cl-indent)
(require 'cl-lib)
(define-slime-contrib slime-indentation
"Contrib interfacing `slime-cl-indent' and SLIME."
(:swank-dependencies swank-indentation)
(:on-load
(setq common-lisp-current-package-function 'slime-current-package)))
(defun slime-update-system-indentation (symbol indent packages)
(let ((list (gethash symbol common-lisp-system-indentation))
(ok nil))
(if (not list)
(puthash symbol (list (cons indent packages))
common-lisp-system-indentation)
(dolist (spec list)
(cond ((equal (car spec) indent)
(dolist (p packages)
(unless (member p (cdr spec))
(push p (cdr spec))))
(setf ok t))
(t
(setf (cdr spec)
(cl-set-difference (cdr spec) packages :test 'equal)))))
(unless ok
(puthash symbol (cons (cons indent packages)
list)
common-lisp-system-indentation)))))
(provide 'slime-indentation)

11
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-listener-hooks.el Normal file
View file

@ -0,0 +1,11 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-listener-hooks
"Enable slime integration in an application'w event loop"
(:authors "Alan Ruttenberg <alanr-l@mumble.net>, R. Mattes <rm@seid-online.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-listener-hooks))
(provide 'slime-listener-hooks)

129
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-macrostep.el Normal file
View file

@ -0,0 +1,129 @@
;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el
;; Authors: Luís Oliveira <luismbo@gmail.com>
;; Jon Oddie <j.j.oddie@gmail.com
;;
;; License: GNU GPL (same license as Emacs)
;;; Description:
;; Fancier in-place macro-expansion using macrostep.el (originally
;; written for Emacs Lisp). To use, position point before the
;; open-paren of the macro call in a SLIME source or REPL buffer, and
;; type `C-c M-e' or `M-x macrostep-expand'. The pretty-printed
;; result of `macroexpand-1' will be inserted inline in the current
;; buffer, which is temporarily read-only while macro expansions are
;; visible. If the expansion is itself a macro call, expansion can be
;; continued by typing `e'. Expansions are collapsed to their
;; original macro forms by typing `c' or `q'. Other macro- and
;; compiler-macro calls in the expansion will be font-locked
;; differently, and point can be moved there quickly by typing `n' or
;; `p'. For more details, see the documentation of
;; `macrostep-expand'.
;;; Code:
(require 'slime)
(eval-and-compile
(require 'macrostep nil t)
;; Use bundled version if not separately installed
(require 'macrostep "../lib/macrostep"))
(eval-when-compile (require 'cl-lib))
(defvar slime-repl-mode-hook)
(defvar slime-repl-mode-map)
(define-slime-contrib slime-macrostep
"Interactive macro expansion via macrostep.el."
(:authors "Luís Oliveira <luismbo@gmail.com>"
"Jon Oddie <j.j.oddie@gmail.com>")
(:license "GPL")
(:swank-dependencies swank-macrostep)
(:on-load
(easy-menu-add-item slime-mode-map '(menu-bar SLIME Debugging)
["Macro stepper..." macrostep-expand (slime-connected-p)]
"Create Trace Buffer")
(add-hook 'slime-mode-hook #'macrostep-slime-mode-hook)
(define-key slime-mode-map (kbd "C-c M-e") #'macrostep-expand)
(eval-after-load 'slime-repl
'(progn
(add-hook 'slime-repl-mode-hook #'macrostep-slime-mode-hook)
(define-key slime-repl-mode-map (kbd "C-c M-e") #'macrostep-expand)))))
(defun macrostep-slime-mode-hook ()
(setq macrostep-sexp-at-point-function #'macrostep-slime-sexp-at-point)
(setq macrostep-environment-at-point-function #'macrostep-slime-context)
(setq macrostep-expand-1-function #'macrostep-slime-expand-1)
(setq macrostep-print-function #'macrostep-slime-insert)
(setq macrostep-macro-form-p-function #'macrostep-slime-macro-form-p))
(defun macrostep-slime-sexp-at-point (&rest _ignore)
(slime-sexp-at-point))
(defun macrostep-slime-context ()
(let (defun-start defun-end)
(save-excursion
(while
(condition-case nil
(progn (backward-up-list) t)
(scan-error nil)))
(setq defun-start (point))
(setq defun-end (scan-sexps (point) 1)))
(list (buffer-substring-no-properties
defun-start (point))
(buffer-substring-no-properties
(scan-sexps (point) 1) defun-end))))
(defun macrostep-slime-expand-1 (string context)
(slime-dcase
(slime-eval
`(swank-macrostep:macrostep-expand-1
,string ,macrostep-expand-compiler-macros ',context))
((:error error-message)
(error "%s" error-message))
((:ok expansion positions)
(list expansion positions))))
(defun macrostep-slime-insert (result _ignore)
"Insert RESULT at point, indenting to match the current column."
(cl-destructuring-bind (expansion positions) result
(let ((start (point))
(column-offset (current-column)))
(insert expansion)
(macrostep-slime--propertize-macros start positions)
(indent-rigidly start (point) column-offset))))
(defun macrostep-slime--propertize-macros (start-offset positions)
"Put text properties on macro forms."
(dolist (position positions)
(cl-destructuring-bind (operator type start)
position
(let ((open-paren-position
(+ start-offset start)))
(put-text-property open-paren-position
(1+ open-paren-position)
'macrostep-macro-start
t)
;; this assumes that the operator starts right next to the
;; opening parenthesis. We could probably be more robust.
(let ((op-start (1+ open-paren-position)))
(put-text-property op-start
(+ op-start (length operator))
'font-lock-face
(if (eq type :macro)
'macrostep-macro-face
'macrostep-compiler-macro-face)))))))
(defun macrostep-slime-macro-form-p (string context)
(slime-dcase
(slime-eval
`(swank-macrostep:macro-form-p
,string ,macrostep-expand-compiler-macros ',context))
((:error error-message)
(error "%s" error-message))
((:ok result)
result)))
(provide 'slime-macrostep)

31
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mdot-fu.el Normal file
View file

@ -0,0 +1,31 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-mdot-fu
"Making M-. work on local functions."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-enclosing-context)
(:on-load
(add-hook 'slime-edit-definition-hooks 'slime-edit-local-definition))
(:on-unload
(remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)))
(defun slime-edit-local-definition (name &optional where)
"Like `slime-edit-definition', but tries to find the definition
in a local function binding near point."
(interactive (list (slime-read-symbol-name "Name: ")))
(cl-multiple-value-bind (binding-name point)
(cl-multiple-value-call #'cl-some #'(lambda (binding-name point)
(when (cl-equalp binding-name name)
(cl-values binding-name point)))
(slime-enclosing-bound-names))
(when (and binding-name point)
(slime-edit-definition-cont
`((,binding-name
,(make-slime-buffer-location (buffer-name (current-buffer)) point)))
name
where))))
(provide 'slime-mdot-fu)

46
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-media.el Normal file
View file

@ -0,0 +1,46 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-media
"Display things other than text in SLIME buffers"
(:authors "Christophe Rhodes <csr21@cantab.net>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-media)
(:on-load
(add-hook 'slime-event-hooks 'slime-dispatch-media-event)))
(defun slime-media-decode-image (image)
(mapcar (lambda (image)
(if (plist-get image :data)
(plist-put image :data (base64-decode-string (plist-get image :data)))
image))
image))
(defun slime-dispatch-media-event (event)
(slime-dcase event
((:write-image image string)
(let ((img (or (find-image (slime-media-decode-image image))
(create-image image))))
(slime-media-insert-image img string))
t)
((:popup-buffer bufname string mode)
(slime-with-popup-buffer (bufname :connection t :package t)
(when mode (funcall mode))
(princ string)
(goto-char (point-min)))
t)
(t nil)))
(defun slime-media-insert-image (image string &optional bol)
(with-current-buffer (slime-output-buffer)
(let ((marker (slime-repl-output-target-marker :repl-result)))
(goto-char marker)
(slime-propertize-region `(face slime-repl-result-face
rear-nonsticky (face))
(insert-image image string))
;; Move the input-start marker after the REPL result.
(set-marker marker (point)))
(slime-repl-show-maximum-output)))
(provide 'slime-media)

150
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-mrepl.el Normal file
View file

@ -0,0 +1,150 @@
;; An experimental implementation of multiple REPLs multiplexed over a
;; single Slime socket. M-x slime-new-mrepl creates a new REPL buffer.
;;
(require 'slime)
(require 'inferior-slime) ; inferior-slime-indent-lime
(require 'cl-lib)
(define-slime-contrib slime-mrepl
"Multiple REPLs."
(:authors "Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:swank-dependencies swank-mrepl))
(require 'comint)
(defvar slime-mrepl-remote-channel nil)
(defvar slime-mrepl-expect-sexp nil)
(define-derived-mode slime-mrepl-mode comint-mode "mrepl"
;; idea lifted from ielm
(unless (get-buffer-process (current-buffer))
(let* ((process-connection-type nil)
(proc (start-process "mrepl (dummy)" (current-buffer) "hexl")))
(set-process-query-on-exit-flag proc nil)))
(set (make-local-variable 'comint-use-prompt-regexp) nil)
(set (make-local-variable 'comint-inhibit-carriage-motion) t)
(set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender)
(set (make-local-variable 'comint-output-filter-functions) nil)
(set (make-local-variable 'slime-mrepl-expect-sexp) t)
;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input)
(set-syntax-table lisp-mode-syntax-table)
)
(slime-define-keys slime-mrepl-mode-map
((kbd "RET") 'slime-mrepl-return)
([return] 'slime-mrepl-return)
;;((kbd "TAB") 'slime-indent-and-complete-symbol)
((kbd "C-c C-b") 'slime-interrupt)
((kbd "C-c C-c") 'slime-interrupt))
(defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid
(defun slime-mrepl-mark () (process-mark (slime-mrepl-process%)))
(defun slime-mrepl-insert (string)
(comint-output-filter (slime-mrepl-process%) string))
(slime-define-channel-type listener)
(slime-define-channel-method listener :prompt (package prompt)
(with-current-buffer (slime-channel-get self 'buffer)
(slime-mrepl-prompt package prompt)))
(defun slime-mrepl-prompt (package prompt)
(setf slime-buffer-package package)
(slime-mrepl-insert (format "%s%s> "
(cl-case (current-column)
(0 "")
(t "\n"))
prompt))
(slime-mrepl-recenter))
(defun slime-mrepl-recenter ()
(when (get-buffer-window)
(recenter -1)))
(slime-define-channel-method listener :write-result (result)
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (point-max))
(slime-mrepl-insert result)))
(slime-define-channel-method listener :evaluation-aborted ()
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (point-max))
(slime-mrepl-insert "; Evaluation aborted\n")))
(slime-define-channel-method listener :write-string (string)
(slime-mrepl-write-string self string))
(defun slime-mrepl-write-string (self string)
(with-current-buffer (slime-channel-get self 'buffer)
(goto-char (slime-mrepl-mark))
(slime-mrepl-insert string)))
(slime-define-channel-method listener :set-read-mode (mode)
(with-current-buffer (slime-channel-get self 'buffer)
(cl-ecase mode
(:read (setq slime-mrepl-expect-sexp nil)
(message "[Listener is waiting for input]"))
(:eval (setq slime-mrepl-expect-sexp t)))))
(defun slime-mrepl-return (&optional end-of-input)
(interactive "P")
(slime-check-connected)
(goto-char (point-max))
(cond ((and slime-mrepl-expect-sexp
(or (slime-input-complete-p (slime-mrepl-mark) (point))
end-of-input))
(comint-send-input))
((not slime-mrepl-expect-sexp)
(unless end-of-input
(insert "\n"))
(comint-send-input t))
(t
(insert "\n")
(inferior-slime-indent-line)
(message "[input not complete]")))
(slime-mrepl-recenter))
(defun slime-mrepl-input-sender (proc string)
(slime-mrepl-send-string (substring-no-properties string)))
(defun slime-mrepl-send-string (string &optional command-string)
(slime-mrepl-send `(:process ,string)))
(defun slime-mrepl-send (msg)
"Send MSG to the remote channel."
(slime-send-to-remote-channel slime-mrepl-remote-channel msg))
(defun slime-new-mrepl ()
"Create a new listener window."
(interactive)
(let ((channel (slime-make-channel slime-listener-channel-methods)))
(slime-eval-async
`(swank-mrepl:create-mrepl ,(slime-channel.id channel))
(slime-rcurry
(lambda (result channel)
(cl-destructuring-bind (remote thread-id package prompt) result
(pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl)))
(slime-mrepl-mode)
(setq slime-current-thread thread-id)
(setq slime-buffer-connection (slime-connection))
(set (make-local-variable 'slime-mrepl-remote-channel) remote)
(slime-channel-put channel 'buffer (current-buffer))
(slime-channel-send channel `(:prompt ,package ,prompt))))
channel))))
(defun slime-mrepl ()
(let ((conn (slime-connection)))
(cl-find-if (lambda (x)
(with-current-buffer x
(and (eq major-mode 'slime-mrepl-mode)
(eq (slime-current-connection) conn))))
(buffer-list))))
(def-slime-selector-method ?m
"First mrepl-buffer"
(or (slime-mrepl)
(error "No mrepl buffer (%s)" (slime-connection-name))))
(provide 'slime-mrepl)

320
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-package-fu.el Normal file
View file

@ -0,0 +1,320 @@
(require 'slime)
(require 'slime-c-p-c)
(require 'slime-parse)
(defvar slime-package-fu-init-undo-stack nil)
(define-slime-contrib slime-package-fu
"Exporting/Unexporting symbols at point."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:swank-dependencies swank-package-fu)
(:on-load
(push `(progn (define-key slime-mode-map "\C-cx"
',(lookup-key slime-mode-map "\C-cx")))
slime-package-fu-init-undo-stack)
(define-key slime-mode-map "\C-cx" 'slime-export-symbol-at-point))
(:on-unload
(while slime-c-p-c-init-undo-stack
(eval (pop slime-c-p-c-init-undo-stack)))))
(defvar slime-package-file-candidates
(mapcar #'file-name-nondirectory
'("package.lisp" "packages.lisp" "pkgdcl.lisp"
"defpackage.lisp")))
(defvar slime-export-symbol-representation-function
#'(lambda (n) (format "#:%s" n)))
(defvar slime-export-symbol-representation-auto t
"Determine automatically which style is used for symbols, #: or :
If it's mixed or no symbols are exported so far,
use `slime-export-symbol-representation-function'.")
(defvar slime-export-save-file nil
"Save the package file after each automatic modification")
(defvar slime-defpackage-regexp
"^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*")
(defun slime-find-package-definition-rpc (package)
(slime-eval `(swank:find-definition-for-thing
(swank::guess-package ,package))))
(defun slime-find-package-definition-regexp (package)
(save-excursion
(save-match-data
(goto-char (point-min))
(cl-block nil
(while (re-search-forward slime-defpackage-regexp nil t)
(when (slime-package-equal package (slime-sexp-at-point))
(backward-sexp)
(cl-return (make-slime-file-location (buffer-file-name)
(1- (point))))))))))
(defun slime-package-equal (designator1 designator2)
;; First try to be lucky and compare the strings themselves (for the
;; case when one of the designated packages isn't loaded in the
;; image.) Then try to do it properly using the inferior Lisp which
;; will also resolve nicknames for us &c.
(or (cl-equalp (slime-cl-symbol-name designator1)
(slime-cl-symbol-name designator2))
(slime-eval `(swank:package= ,designator1 ,designator2))))
(defun slime-export-symbol (symbol package)
"Unexport `symbol' from `package' in the Lisp image."
(slime-eval `(swank:export-symbol-for-emacs ,symbol ,package)))
(defun slime-unexport-symbol (symbol package)
"Export `symbol' from `package' in the Lisp image."
(slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package)))
(defun slime-find-possible-package-file (buffer-file-name)
(cl-labels ((file-name-subdirectory (dirname)
(expand-file-name
(concat (file-name-as-directory (slime-to-lisp-filename dirname))
(file-name-as-directory ".."))))
(try (dirname)
(cl-dolist (package-file-name slime-package-file-candidates)
(let ((f (slime-to-lisp-filename
(concat dirname package-file-name))))
(when (file-readable-p f)
(cl-return f))))))
(when buffer-file-name
(let ((buffer-cwd (file-name-directory buffer-file-name)))
(or (try buffer-cwd)
(try (file-name-subdirectory buffer-cwd))
(try (file-name-subdirectory
(file-name-subdirectory buffer-cwd))))))))
(defun slime-goto-package-source-definition (package)
"Tries to find the DEFPACKAGE form of `package'. If found,
places the cursor at the start of the DEFPACKAGE form."
(cl-labels ((try (location)
(when (slime-location-p location)
(slime-goto-source-location location)
t)))
(or (try (slime-find-package-definition-rpc package))
(try (slime-find-package-definition-regexp package))
(try (let ((package-file (slime-find-possible-package-file
(buffer-file-name))))
(when package-file
(with-current-buffer (find-file-noselect package-file t)
(slime-find-package-definition-regexp package)))))
(error "Couldn't find source definition of package: %s" package))))
(defun slime-at-expression-p (pattern)
(when (ignore-errors
;; at a list?
(= (point) (progn (down-list 1)
(backward-up-list 1)
(point))))
(save-excursion
(down-list 1)
(slime-in-expression-p pattern))))
(defun slime-goto-next-export-clause ()
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(save-excursion
(cl-block nil
(while (ignore-errors (slime-forward-sexp) t)
(skip-chars-forward " \n\t")
(when (slime-at-expression-p '(:export *))
(setq point (point))
(cl-return)))))
(if point
(goto-char point)
(error "No next (:export ...) clause found"))))
(defun slime-search-exports-in-defpackage (symbol-name)
"Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((target-symbol-p (symbol)
(string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
(regexp-quote symbol-name))
symbol)))
(save-excursion
(cl-block nil
(while (ignore-errors (slime-goto-next-export-clause) t)
(let ((clause-end (save-excursion (forward-sexp) (point))))
(save-excursion
(while (search-forward symbol-name clause-end t)
(when (target-symbol-p (slime-symbol-at-point))
(cl-return (if (slime-inside-string-p)
;; Include the following "
(1+ (point))
(point))))))))))))
(defun slime-export-symbols ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're at the beginning of :export
(cl-labels ((read-sexp ()
(ignore-errors
(forward-comment (point-max))
(buffer-substring-no-properties
(point) (progn (forward-sexp) (point))))))
(save-excursion
(cl-loop for sexp = (read-sexp) while sexp collect sexp))))
(defun slime-defpackage-exports ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((normalize-name (name)
(if (string-prefix-p "\"" name)
(read name)
(replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
"" name))))
(save-excursion
(mapcar #'normalize-name
(cl-loop while (ignore-errors (slime-goto-next-export-clause) t)
do (down-list) (forward-sexp)
append (slime-export-symbols)
do (up-list) (backward-sexp))))))
(defun slime-symbol-exported-p (name symbols)
(cl-member name symbols :test 'cl-equalp))
(defun slime-frob-defpackage-form (current-package do-what symbols)
"Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
depending on the value of `do-what' which can either be `:export',
or `:unexport'.
Returns t if the symbol was added/removed. Nil if the symbol was
already exported/unexported."
(save-excursion
(slime-goto-package-source-definition current-package)
(down-list 1) ; enter DEFPACKAGE form
(forward-sexp) ; skip DEFPACKAGE symbol
;; Don't or will fail if (:export ...) is immediately following
;; (forward-sexp) ; skip package name
(let ((exported-symbols (slime-defpackage-exports))
(symbols (if (consp symbols)
symbols
(list symbols)))
(number-of-actions 0))
(cl-ecase do-what
(:export
(slime-add-export)
(dolist (symbol symbols)
(let ((symbol-name (slime-cl-symbol-name symbol)))
(unless (slime-symbol-exported-p symbol-name exported-symbols)
(cl-incf number-of-actions)
(slime-insert-export symbol-name)))))
(:unexport
(dolist (symbol symbols)
(let ((symbol-name (slime-cl-symbol-name symbol)))
(when (slime-symbol-exported-p symbol-name exported-symbols)
(slime-remove-export symbol-name)
(cl-incf number-of-actions))))))
(when slime-export-save-file
(save-buffer))
number-of-actions)))
(defun slime-add-export ()
(let (point)
(save-excursion
(while (ignore-errors (slime-goto-next-export-clause) t)
(setq point (point))))
(cond (point
(goto-char point)
(down-list)
(slime-end-of-list))
(t
(slime-end-of-list)
(unless (looking-back "^\\s-*")
(newline-and-indent))
(insert "(:export ")
(save-excursion (insert ")"))))))
(defun slime-determine-symbol-style ()
;; Assumes we're inside :export
(save-excursion
(slime-beginning-of-list)
(slime-forward-sexp)
(let ((symbols (slime-export-symbols)))
(cond ((null symbols)
slime-export-symbol-representation-function)
((cl-every (lambda (x)
(string-match "^:" x))
symbols)
(lambda (n) (format ":%s" n)))
((cl-every (lambda (x)
(string-match "^#:" x))
symbols)
(lambda (n) (format "#:%s" n)))
((cl-every (lambda (x)
(string-prefix-p "\"" x))
symbols)
(lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
(t
slime-export-symbol-representation-function)))))
(defun slime-format-symbol-for-defpackage (symbol-name)
(funcall (if slime-export-symbol-representation-auto
(slime-determine-symbol-style)
slime-export-symbol-representation-function)
symbol-name))
(defun slime-insert-export (symbol-name)
;; Assumes we're at the inside :export after the last symbol
(let ((symbol-name (slime-format-symbol-for-defpackage symbol-name)))
(unless (looking-back "^\\s-*")
(newline-and-indent))
(insert symbol-name)))
(defun slime-remove-export (symbol-name)
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(while (setq point (slime-search-exports-in-defpackage symbol-name))
(save-excursion
(goto-char point)
(backward-sexp)
(delete-region (point) point)
(beginning-of-line)
(when (looking-at "^\\s-*$")
(join-line)
(delete-trailing-whitespace (point) (line-end-position)))))))
(defun slime-export-symbol-at-point ()
"Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
(interactive)
(let ((package (slime-current-package))
(symbol (slime-symbol-at-point)))
(unless symbol (error "No symbol at point."))
(cond (current-prefix-arg
(if (cl-plusp (slime-frob-defpackage-form package :unexport symbol))
(message "Symbol `%s' no longer exported form `%s'"
symbol package)
(message "Symbol `%s' is not exported from `%s'"
symbol package))
(slime-unexport-symbol symbol package))
(t
(if (cl-plusp (slime-frob-defpackage-form package :export symbol))
(message "Symbol `%s' now exported from `%s'"
symbol package)
(message "Symbol `%s' already exported from `%s'"
symbol package))
(slime-export-symbol symbol package)))))
(defun slime-export-class (name)
"Export acessors, constructors, etc. associated with a structure or a class"
(interactive (list (slime-read-from-minibuffer "Export structure named: "
(slime-symbol-at-point))))
(let* ((package (slime-current-package))
(symbols (slime-eval `(swank:export-structure ,name ,package))))
(message "%s symbols exported from `%s'"
(slime-frob-defpackage-form package :export symbols)
package)))
(defalias 'slime-export-structure 'slime-export-class)
(provide 'slime-package-fu)
;; Local Variables:
;; indent-tabs-mode: nil
;; End:

358
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-parse.el Normal file
View file

@ -0,0 +1,358 @@
(require 'slime)
(require 'cl-lib)
(define-slime-contrib slime-parse
"Utility contrib containg functions to parse forms in a buffer."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL"))
(defun slime-parse-form-until (limit form-suffix)
"Parses form from point to `limit'."
;; For performance reasons, this function does not use recursion.
(let ((todo (list (point))) ; stack of positions
(sexps) ; stack of expressions
(cursexp)
(curpos)
(depth 1)) ; This function must be called from the
; start of the sexp to be parsed.
(while (and (setq curpos (pop todo))
(progn
(goto-char curpos)
;; (Here we also move over suppressed
;; reader-conditionalized code! Important so CL-side
;; of autodoc won't see that garbage.)
(ignore-errors (slime-forward-cruft))
(< (point) limit)))
(setq cursexp (pop sexps))
(cond
;; End of an sexp?
((or (looking-at "\\s)") (eolp))
(cl-decf depth)
(push (nreverse cursexp) (car sexps)))
;; Start of a new sexp?
((looking-at "\\s'*@*\\s(")
(let ((subpt (match-end 0)))
(ignore-errors
(forward-sexp)
;; (In case of error, we're at an incomplete sexp, and
;; nothing's left todo after it.)
(push (point) todo))
(push cursexp sexps)
(push subpt todo) ; to descend into new sexp
(push nil sexps)
(cl-incf depth)))
;; In mid of an sexp..
(t
(let ((pt1 (point))
(pt2 (condition-case e
(progn (forward-sexp) (point))
(scan-error
(cl-fourth e))))) ; end of sexp
(push (buffer-substring-no-properties pt1 pt2) cursexp)
(push pt2 todo)
(push cursexp sexps)))))
(when sexps
(setf (car sexps) (cl-nreconc form-suffix (car sexps)))
(while (> depth 1)
(push (nreverse (pop sexps)) (car sexps))
(cl-decf depth))
(nreverse (car sexps)))))
(defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
"Returns t if the character that `get-char-fn' yields has
characer syntax of `syntax'. If `unescaped' is true, it's ensured
that the character is not escaped."
(let ((char (funcall get-char-fn (point)))
(char-before (funcall get-char-fn (1- (point)))))
(if (and char (eq (char-syntax char) (aref syntax 0)))
(if unescaped
(or (null char-before)
(not (eq (char-syntax char-before) ?\\)))
t)
nil)))
(defconst slime-cursor-marker 'swank::%cursor-marker%)
(defun slime-parse-form-upto-point (&optional max-levels)
(save-restriction
;; Don't parse more than 500 lines before point, so we don't spend
;; too much time. NB. Make sure to go to beginning of line, and
;; not possibly anywhere inside comments or strings.
(narrow-to-region (line-beginning-position -500) (point-max))
(save-excursion
(let ((suffix (list slime-cursor-marker)))
(cond ((slime-compare-char-syntax #'char-after "(" t)
;; We're at the start of some expression, so make sure
;; that SWANK::%CURSOR-MARKER% will come after that
;; expression. If the expression is not balanced, make
;; still sure that the marker does *not* come directly
;; after the preceding expression.
(or (ignore-errors (forward-sexp) t)
(push "" suffix)))
((or (bolp) (slime-compare-char-syntax #'char-before " " t))
;; We're after some expression, so we have to make sure
;; that %CURSOR-MARKER% does *not* come directly after
;; that expression.
(push "" suffix))
((slime-compare-char-syntax #'char-before "(" t)
;; We're directly after an opening parenthesis, so we
;; have to make sure that something comes before
;; %CURSOR-MARKER%.
(push "" suffix))
(t
;; We're at a symbol, so make sure we get the whole symbol.
(slime-end-of-symbol)))
(let ((pt (point)))
(ignore-errors (up-list (if max-levels (- max-levels) -5)))
(ignore-errors (down-list))
(slime-parse-form-until pt suffix))))))
(require 'bytecomp)
(mapc (lambda (sym)
(cond ((fboundp sym)
(unless (byte-code-function-p (symbol-function sym))
(byte-compile sym)))
(t (error "%S is not fbound" sym))))
'(slime-parse-form-upto-point
slime-parse-form-until
slime-compare-char-syntax))
;;;; Test cases
(defun slime-extract-context ()
"Parse the context for the symbol at point.
Nil is returned if there's no symbol at point. Otherwise we detect
the following cases (the . shows the point position):
(defun n.ame (...) ...) -> (:defun name)
(defun (setf n.ame) (...) ...) -> (:defun (setf name))
(defmethod n.ame (...) ...) -> (:defmethod name (...))
(defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
(defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
(defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
(defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
(defmacro n.ame (...) ...) -> (:defmacro name)
(defsetf n.ame (...) ...) -> (:defsetf name)
(define-setf-expander n.ame (...) ...) -> (:define-setf-expander name)
(define-modify-macro n.ame (...) ...) -> (:define-modify-macro name)
(define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
(defvar n.ame (...) ...) -> (:defvar name)
(defparameter n.ame ...) -> (:defparameter name)
(defconstant n.ame ...) -> (:defconstant name)
(defclass n.ame ...) -> (:defclass name)
(defstruct n.ame ...) -> (:defstruct name)
(defpackage n.ame ...) -> (:defpackage name)
For other contexts we return the symbol at point."
(let ((name (slime-symbol-at-point)))
(if name
(let ((symbol (read name)))
(or (progn ;;ignore-errors
(slime-parse-context symbol))
symbol)))))
(defun slime-parse-context (name)
(save-excursion
(cond ((slime-in-expression-p '(defun *)) `(:defun ,name))
((slime-in-expression-p '(defmacro *)) `(:defmacro ,name))
((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
((slime-in-expression-p '(setf *))
;;a setf-definition, but which?
(backward-up-list 1)
(slime-parse-context `(setf ,name)))
((slime-in-expression-p '(defmethod *))
(unless (looking-at "\\s ")
(forward-sexp 1)) ; skip over the methodname
(let (qualifiers arglist)
(cl-loop for e = (read (current-buffer))
until (listp e) do (push e qualifiers)
finally (setq arglist e))
`(:defmethod ,name ,@qualifiers
,(slime-arglist-specializers arglist))))
((and (symbolp name)
(slime-in-expression-p `(,name)))
;; looks like a regular call
(let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
(cond ((slime-in-expression-p `(setf (*))) ;a setf-call
(if toplevel
`(:call ,toplevel (setf ,name))
`(setf ,name)))
((not toplevel)
name)
((slime-in-expression-p `(labels ((*))))
`(:labels ,toplevel ,name))
((slime-in-expression-p `(flet ((*))))
`(:flet ,toplevel ,name))
(t
`(:call ,toplevel ,name)))))
((slime-in-expression-p '(define-compiler-macro *))
`(:define-compiler-macro ,name))
((slime-in-expression-p '(define-modify-macro *))
`(:define-modify-macro ,name))
((slime-in-expression-p '(define-setf-expander *))
`(:define-setf-expander ,name))
((slime-in-expression-p '(defsetf *))
`(:defsetf ,name))
((slime-in-expression-p '(defvar *)) `(:defvar ,name))
((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
((slime-in-expression-p '(defconstant *)) `(:defconstant ,name))
((slime-in-expression-p '(defclass *)) `(:defclass ,name))
((slime-in-expression-p '(defpackage *)) `(:defpackage ,name))
((slime-in-expression-p '(defstruct *))
`(:defstruct ,(if (consp name)
(car name)
name)))
(t
name))))
(defun slime-in-expression-p (pattern)
"A helper function to determine the current context.
The pattern can have the form:
pattern ::= () ;matches always
| (*) ;matches inside a list
| (<symbol> <pattern>) ;matches if the first element in
; the current list is <symbol> and
; if <pattern> matches.
| ((<pattern>)) ;matches if we are in a nested list."
(save-excursion
(let ((path (reverse (slime-pattern-path pattern))))
(cl-loop for p in path
always (ignore-errors
(cl-etypecase p
(symbol (slime-beginning-of-list)
(eq (read (current-buffer)) p))
(number (backward-up-list p)
t)))))))
(defun slime-pattern-path (pattern)
;; Compute the path to the * in the pattern to make matching
;; easier. The path is a list of symbols and numbers. A number
;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
(if (null pattern)
'()
(cl-etypecase (car pattern)
((member *) '())
(symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
(cons (cons 1 (slime-pattern-path (car pattern)))))))
(defun slime-beginning-of-list (&optional up)
"Move backward to the beginning of the current expression.
Point is placed before the first expression in the list."
(backward-up-list (or up 1))
(down-list 1)
(skip-syntax-forward " "))
(defun slime-end-of-list (&optional up)
(backward-up-list (or up 1))
(forward-list 1)
(down-list -1))
(defun slime-parse-toplevel-form ()
(ignore-errors ; (foo)
(save-excursion
(goto-char (car (slime-region-for-defun-at-point)))
(down-list 1)
(forward-sexp 1)
(slime-parse-context (read (current-buffer))))))
(defun slime-arglist-specializers (arglist)
(cond ((or (null arglist)
(member (cl-first arglist) '(&optional &key &rest &aux)))
(list))
((consp (cl-first arglist))
(cons (cl-second (cl-first arglist))
(slime-arglist-specializers (cl-rest arglist))))
(t
(cons 't
(slime-arglist-specializers (cl-rest arglist))))))
(defun slime-definition-at-point (&optional only-functional)
"Return object corresponding to the definition at point."
(let ((toplevel (slime-parse-toplevel-form)))
(if (or (symbolp toplevel)
(and only-functional
(not (member (car toplevel)
'(:defun :defgeneric :defmethod
:defmacro :define-compiler-macro)))))
(error "Not in a definition")
(slime-dcase toplevel
(((:defun :defgeneric) symbol)
(format "#'%s" symbol))
(((:defmacro :define-modify-macro) symbol)
(format "(macro-function '%s)" symbol))
((:define-compiler-macro symbol)
(format "(compiler-macro-function '%s)" symbol))
((:defmethod symbol &rest args)
(declare (ignore args))
(format "#'%s" symbol))
(((:defparameter :defvar :defconstant) symbol)
(format "'%s" symbol))
(((:defclass :defstruct) symbol)
(format "(find-class '%s)" symbol))
((:defpackage symbol)
(format "(or (find-package '%s) (error \"Package %s not found\"))"
symbol symbol))
(t
(error "Not in a definition"))))))
(defsubst slime-current-parser-state ()
;; `syntax-ppss' does not save match data as it invokes
;; `beginning-of-defun' implicitly which does not save match
;; data. This issue has been reported to the Emacs maintainer on
;; Feb27.
(syntax-ppss))
(defun slime-inside-string-p ()
(nth 3 (slime-current-parser-state)))
(defun slime-inside-comment-p ()
(nth 4 (slime-current-parser-state)))
(defun slime-inside-string-or-comment-p ()
(let ((state (slime-current-parser-state)))
(or (nth 3 state) (nth 4 state))))
;;; The following two functions can be handy when inspecting
;;; source-location while debugging `M-.'.
;;;
(defun slime-current-tlf-number ()
"Return the current toplevel number."
(interactive)
(let ((original-pos (car (slime-region-for-defun-at-point)))
(n 0))
(save-excursion
;; We use this and no repeated `beginning-of-defun's to get
;; reader conditionals right.
(goto-char (point-min))
(while (progn (slime-forward-sexp)
(< (point) original-pos))
(cl-incf n)))
n))
;;; This is similiar to `slime-enclosing-form-paths' in the
;;; `slime-parse' contrib except that this does not do any duck-tape
;;; parsing, and gets reader conditionals right.
(defun slime-current-form-path ()
"Returns the path from the beginning of the current toplevel
form to the atom at point, or nil if we're in front of a tlf."
(interactive)
(let ((source-path nil))
(save-excursion
;; Moving forward to get reader conditionals right.
(cl-loop for inner-pos = (point)
for outer-pos = (cl-nth-value 1 (slime-current-parser-state))
while outer-pos do
(goto-char outer-pos)
(unless (eq (char-before) ?#) ; when at #(...) continue.
(forward-char)
(let ((n 0))
(while (progn (slime-forward-sexp)
(< (point) inner-pos))
(cl-incf n))
(push n source-path)
(goto-char outer-pos)))))
source-path))
(provide 'slime-parse)

18
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentation-streams.el Normal file
View file

@ -0,0 +1,18 @@
(eval-and-compile
(require 'slime))
(define-slime-contrib slime-presentation-streams
"Streams that allow attaching object identities to portions of
output."
(:authors "Alan Ruttenberg <alanr-l@mumble.net>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Helmut Eller <heller@common-lisp.net>")
(:license "GPL")
(:on-load
(add-hook 'slime-connected-hook 'slime-presentation-streams-on-connected))
(:swank-dependencies swank-presentation-streams))
(defun slime-presentation-streams-on-connected ()
(slime-eval `(swank:init-presentation-streams)))
(provide 'slime-presentation-streams)

872
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-presentations.el Normal file
View file

@ -0,0 +1,872 @@
(require 'slime)
(require 'bridge)
(require 'cl-lib)
(eval-when-compile
(require 'cl))
(define-slime-contrib slime-presentations
"Imitate LispM presentations."
(:authors "Alan Ruttenberg <alanr-l@mumble.net>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-presentations)
(:on-load
(add-hook 'slime-repl-mode-hook
(lambda ()
;; Respect the syntax text properties of presentation.
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(add-hook 'after-change-functions
'slime-after-change-function 'append t)))
(add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
(setq slime-write-string-function 'slime-presentation-write)
(add-hook 'slime-connected-hook 'slime-presentations-on-connected)
(add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
(add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
(add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
(add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
(add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
(setq sldb-insert-frame-variable-value-function
'slime-presentation-sldb-insert-frame-variable-value)
(slime-presentation-init-keymaps)
(slime-presentation-add-easy-menu)))
;; To get presentations in the inspector as well, add this to your
;; init file.
;;
;; (eval-after-load 'slime-presentations
;; '(setq slime-inspector-insert-ispec-function
;; 'slime-presentation-inspector-insert-ispec))
;;
(defface slime-repl-output-mouseover-face
'((t (:box (:line-width 1 :color "black" :style released-button)
:inherit slime-repl-inputed-output-face)))
"Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
:group 'slime-repl)
(defface slime-repl-inputed-output-face
'((((class color) (background light)) (:foreground "Red"))
(((class color) (background dark)) (:foreground "Red"))
(t (:slant italic)))
"Face for the result of an evaluation in the SLIME REPL."
:group 'slime-repl)
;; FIXME: This conditional is not right - just used because the code
;; here does not work in XEmacs.
(when (boundp 'text-property-default-nonsticky)
(pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
:test 'equal)
(pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
:test 'equal))
(make-variable-buffer-local
(defvar slime-presentation-start-to-point (make-hash-table)))
(defun slime-mark-presentation-start (id &optional target)
"Mark the beginning of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(setf (gethash id slime-presentation-start-to-point)
;; We use markers because text can also be inserted before this presentation.
;; (Output arrives while we are writing presentations within REPL results.)
(copy-marker (slime-repl-output-target-marker target) nil)))
(defun slime-mark-presentation-start-handler (process string)
(if (and string (string-match "<\\([-0-9]+\\)" string))
(let* ((match (substring string (match-beginning 1) (match-end 1)))
(id (car (read-from-string match))))
(slime-mark-presentation-start id))))
(defun slime-mark-presentation-end (id &optional target)
"Mark the end of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(let ((start (gethash id slime-presentation-start-to-point)))
(remhash id slime-presentation-start-to-point)
(when start
(let* ((marker (slime-repl-output-target-marker target))
(buffer (and marker (marker-buffer marker))))
(with-current-buffer buffer
(let ((end (marker-position marker)))
(slime-add-presentation-properties start end
id nil)))))))
(defun slime-mark-presentation-end-handler (process string)
(if (and string (string-match ">\\([-0-9]+\\)" string))
(let* ((match (substring string (match-beginning 1) (match-end 1)))
(id (car (read-from-string match))))
(slime-mark-presentation-end id))))
(cl-defstruct slime-presentation text id)
(defvar slime-presentation-syntax-table
(let ((table (copy-syntax-table lisp-mode-syntax-table)))
;; We give < and > parenthesis syntax, so that #< ... > is treated
;; as a balanced expression. This allows to use C-M-k, C-M-SPC,
;; etc. to deal with a whole presentation. (For Lisp mode, this
;; is not desirable, since we do not wish to get a mismatched
;; paren highlighted everytime we type < or >.)
(modify-syntax-entry ?< "(>" table)
(modify-syntax-entry ?> ")<" table)
table)
"Syntax table for presentations.")
(defun slime-add-presentation-properties (start end id result-p)
"Make the text between START and END a presentation with ID.
RESULT-P decides whether a face for a return value or output text is used."
(let* ((text (buffer-substring-no-properties start end))
(presentation (make-slime-presentation :text text :id id)))
(let ((inhibit-modification-hooks t))
(add-text-properties start end
`(modification-hooks (slime-after-change-function)
insert-in-front-hooks (slime-after-change-function)
insert-behind-hooks (slime-after-change-function)
syntax-table ,slime-presentation-syntax-table
rear-nonsticky t))
;; Use the presentation as the key of a text property
(case (- end start)
(0)
(1
(add-text-properties start end
`(slime-repl-presentation ,presentation
,presentation :start-and-end)))
(t
(add-text-properties start (1+ start)
`(slime-repl-presentation ,presentation
,presentation :start))
(when (> (- end start) 2)
(add-text-properties (1+ start) (1- end)
`(,presentation :interior)))
(add-text-properties (1- end) end
`(slime-repl-presentation ,presentation
,presentation :end))))
;; Also put an overlay for the face and the mouse-face. This enables
;; highlighting of nested presentations. However, overlays get lost
;; when we copy a presentation; their removal is also not undoable.
;; In these cases the mouse-face text properties need to take over ---
;; but they do not give nested highlighting.
(slime-ensure-presentation-overlay start end presentation))))
(defvar slime-presentation-map (make-sparse-keymap))
(defun slime-ensure-presentation-overlay (start end presentation)
(unless (cl-find presentation (overlays-at start)
:key (lambda (overlay)
(overlay-get overlay 'slime-repl-presentation)))
(let ((overlay (make-overlay start end (current-buffer) t nil)))
(overlay-put overlay 'slime-repl-presentation presentation)
(overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
(overlay-put overlay 'help-echo
(if (eq major-mode 'slime-repl-mode)
"mouse-2: copy to input; mouse-3: menu"
"mouse-2: inspect; mouse-3: menu"))
(overlay-put overlay 'face 'slime-repl-inputed-output-face)
(overlay-put overlay 'keymap slime-presentation-map))))
(defun slime-remove-presentation-properties (from to presentation)
(let ((inhibit-read-only t))
(remove-text-properties from to
`(,presentation t syntax-table t rear-nonsticky t))
(when (eq (get-text-property from 'slime-repl-presentation) presentation)
(remove-text-properties from (1+ from) `(slime-repl-presentation t)))
(when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
(remove-text-properties (1- to) to `(slime-repl-presentation t)))
(dolist (overlay (overlays-at from))
(when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
(delete-overlay overlay)))))
(defun slime-insert-presentation (string output-id &optional rectangle)
"Insert STRING in current buffer and mark it as a presentation
corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line
strings to line up below the current point."
(cl-labels ((insert-it ()
(if rectangle
(slime-insert-indented string)
(insert string))))
(let ((start (point)))
(insert-it)
(slime-add-presentation-properties start (point) output-id t))))
(defun slime-presentation-whole-p (presentation start end &optional object)
(let ((object (or object (current-buffer))))
(string= (etypecase object
(buffer (with-current-buffer object
(buffer-substring-no-properties start end)))
(string (substring-no-properties object start end)))
(slime-presentation-text presentation))))
(defun slime-presentations-around-point (point &optional object)
(let ((object (or object (current-buffer))))
(loop for (key value . rest) on (text-properties-at point object) by 'cddr
when (slime-presentation-p key)
collect key)))
(defun slime-presentation-start-p (tag)
(memq tag '(:start :start-and-end)))
(defun slime-presentation-stop-p (tag)
(memq tag '(:end :start-and-end)))
(cl-defun slime-presentation-start (point presentation
&optional (object (current-buffer)))
"Find start of `presentation' at `point' in `object'.
Return buffer index and whether a start-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-start-p this-presentation))
(let ((change-point (previous-single-property-change
point presentation object (point-min))))
(unless change-point
(return-from slime-presentation-start
(values (etypecase object
(buffer (with-current-buffer object 1))
(string 0))
nil)))
(setq this-presentation (get-text-property change-point
presentation object))
(unless this-presentation
(return-from slime-presentation-start
(values point nil)))
(setq point change-point)))
(values point t)))
(cl-defun slime-presentation-end (point presentation
&optional (object (current-buffer)))
"Find end of presentation at `point' in `object'. Return buffer
index (after last character of the presentation) and whether an
end-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-stop-p this-presentation))
(let ((change-point (next-single-property-change
point presentation object)))
(unless change-point
(return-from slime-presentation-end
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
nil)))
(setq point change-point)
(setq this-presentation (get-text-property point
presentation object))))
(if this-presentation
(let ((after-end (next-single-property-change point
presentation object)))
(if (not after-end)
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
t)
(values after-end t)))
(values point nil))))
(cl-defun slime-presentation-bounds (point presentation
&optional (object (current-buffer)))
"Return start index and end index of `presentation' around `point'
in `object', and whether the presentation is complete."
(multiple-value-bind (start good-start)
(slime-presentation-start point presentation object)
(multiple-value-bind (end good-end)
(slime-presentation-end point presentation object)
(values start end
(and good-start good-end
(slime-presentation-whole-p presentation
start end object))))))
(defun slime-presentation-around-point (point &optional object)
"Return presentation, start index, end index, and whether the
presentation is complete."
(let ((object (or object (current-buffer)))
(innermost-presentation nil)
(innermost-start 0)
(innermost-end most-positive-fixnum))
(dolist (presentation (slime-presentations-around-point point object))
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(when whole-p
(when (< (- end start) (- innermost-end innermost-start))
(setq innermost-start start
innermost-end end
innermost-presentation presentation)))))
(values innermost-presentation
innermost-start innermost-end)))
(defun slime-presentation-around-or-before-point (point &optional object)
(let ((object (or object (current-buffer))))
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-point point object)
(if (or presentation (= point (point-min)))
(values presentation start end whole-p)
(slime-presentation-around-point (1- point) object)))))
(defun slime-presentation-around-or-before-point-or-error (point)
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point point)
(unless presentation
(error "No presentation at point"))
(values presentation start end whole-p)))
(cl-defun slime-for-each-presentation-in-region (from to function
&optional (object (current-buffer)))
"Call `function' with arguments `presentation', `start', `end',
`whole-p' for every presentation in the region `from'--`to' in the
string or buffer `object'."
(cl-labels ((handle-presentation (presentation point)
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(funcall function presentation start end whole-p))))
;; Handle presentations active at `from'.
(dolist (presentation (slime-presentations-around-point from object))
(handle-presentation presentation from))
;; Use the `slime-repl-presentation' property to search for new presentations.
(let ((point from))
(while (< point to)
(setq point (next-single-property-change point 'slime-repl-presentation
object to))
(let* ((presentation (get-text-property point 'slime-repl-presentation object))
(status (get-text-property point presentation object)))
(when (slime-presentation-start-p status)
(handle-presentation presentation point)))))))
;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
;; xemacs-beta@xemacs.org of 18 Mar 2002
(unless (boundp 'undo-in-progress)
(defvar undo-in-progress nil
"Placeholder defvar for XEmacs compatibility from SLIME.")
(defadvice undo-more (around slime activate)
(let ((undo-in-progress t)) ad-do-it)))
(defun slime-after-change-function (start end &rest ignore)
"Check all presentations within and adjacent to the change.
When a presentation has been altered, change it to plain text."
(let ((inhibit-modification-hooks t))
(let ((real-start (max 1 (1- start)))
(real-end (min (1+ (buffer-size)) (1+ end)))
(any-change nil))
;; positions around the change
(slime-for-each-presentation-in-region
real-start real-end
(lambda (presentation from to whole-p)
(cond
(whole-p
(slime-ensure-presentation-overlay from to presentation))
((not undo-in-progress)
(slime-remove-presentation-properties from to
presentation)
(setq any-change t)))))
(when any-change
(undo-boundary)))))
(defun slime-presentation-around-click (event)
"Return the presentation around the position of the mouse-click EVENT.
If there is no presentation, signal an error.
Also return the start position, end position, and buffer of the presentation."
(when (and (featurep 'xemacs) (not (button-press-event-p event)))
(error "Command must be bound to a button-press-event"))
(let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event))))
(with-current-buffer (window-buffer window)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point point)
(unless presentation
(error "No presentation at click"))
(values presentation start end (current-buffer))))))
(defun slime-check-presentation (from to buffer presentation)
(unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object
',(slime-presentation-id presentation))))
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))))
(defun slime-copy-or-inspect-presentation-at-mouse (event)
(interactive "e") ; no "@" -- we don't want to select the clicked-at window
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-check-presentation start end buffer presentation)
(if (with-current-buffer buffer
(eq major-mode 'slime-repl-mode))
(slime-copy-presentation-at-mouse-to-repl event)
(slime-inspect-presentation-at-mouse event))))
(defun slime-inspect-presentation (presentation start end buffer)
(let ((reset-p
(with-current-buffer buffer
(not (eq major-mode 'slime-inspector-mode)))))
(slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
'slime-open-inspector)))
(defun slime-inspect-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-inspect-presentation presentation start end buffer)))
(defun slime-inspect-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-inspect-presentation presentation start end (current-buffer))))
(defun slime-M-.-presentation (presentation start end buffer &optional where)
(let* ((id (slime-presentation-id presentation))
(presentation-string (format "Presentation %s" id))
(location (slime-eval `(swank:find-definition-for-thing
(swank:lookup-presented-object
',(slime-presentation-id presentation))))))
(unless (eq (car location) :error)
(slime-edit-definition-cont
(and location (list (make-slime-xref :dspec `(,presentation-string)
:location location)))
presentation-string
where))))
(defun slime-M-.-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-M-.-presentation presentation start end buffer)))
(defun slime-M-.-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-M-.-presentation presentation start end (current-buffer))))
(defun slime-edit-presentation (name &optional where)
(if (or current-prefix-arg (not (equal (slime-symbol-at-point) name)))
nil ; NAME came from user explicitly, so decline.
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point (point))
(when presentation
(slime-M-.-presentation presentation start end (current-buffer) where)))))
(defun slime-copy-presentation-to-repl (presentation start end buffer)
(let ((text (with-current-buffer buffer
;; we use the buffer-substring rather than the
;; presentation text to capture any overlays
(buffer-substring start end)))
(id (slime-presentation-id presentation)))
(unless (integerp id)
(setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id))))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(cl-flet ((do-insertion ()
(unless (looking-back "\\s-" (- (point) 1))
(insert " "))
(slime-insert-presentation text id)
(unless (or (eolp) (looking-at "\\s-"))
(insert " "))))
(if (>= (point) slime-repl-prompt-start-mark)
(do-insertion)
(save-excursion
(goto-char (point-max))
(do-insertion))))))
(defun slime-copy-presentation-at-mouse-to-repl (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-repl presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-repl (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-repl presentation start end (current-buffer))))
(defun slime-copy-presentation-at-mouse-to-point (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(when (not (string-match "\\s-"
(buffer-substring (1- (point)) (point))))
(insert " "))
(insert presentation-text)
(slime-after-change-function (point) (point))
(when (and (not (eolp)) (not (looking-at "\\s-")))
(insert " ")))))
(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(kill-new presentation-text)
(message "Saved presentation \"%s\" to kill ring" presentation-text)))
(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-kill-ring presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-kill-ring (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
(defun slime-describe-presentation (presentation)
(slime-eval-describe
`(swank::describe-to-string
(swank:lookup-presented-object ',(slime-presentation-id presentation)))))
(defun slime-describe-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-describe-presentation presentation)))
(defun slime-describe-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-describe-presentation presentation)))
(defun slime-pretty-print-presentation (presentation)
(slime-eval-describe
`(swank::swank-pprint
(cl:list
(swank:lookup-presented-object ',(slime-presentation-id presentation))))))
(defun slime-pretty-print-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-pretty-print-presentation presentation)))
(defun slime-pretty-print-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-pretty-print-presentation presentation)))
(defun slime-mark-presentation (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(goto-char start)
(push-mark end nil t)))
(defun slime-previous-presentation (&optional arg)
"Move point to the beginning of the first presentation before point.
With ARG, do this that many times.
A negative argument means move forward instead."
(interactive "p")
(unless arg (setq arg 1))
(slime-next-presentation (- arg)))
(defun slime-next-presentation (&optional arg)
"Move point to the beginning of the next presentation after point.
With ARG, do this that many times.
A negative argument means move backward instead."
(interactive "p")
(unless arg (setq arg 1))
(cond
((plusp arg)
(dotimes (i arg)
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char end)))
(let ((p (next-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No next presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))
((minusp arg)
(dotimes (i (- arg))
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char start)))
(let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No previous presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))))
(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu)
(when (featurep 'xemacs)
(define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [button3] 'slime-presentation-menu))
;; protocol for handling up a menu.
;; 1. Send lisp message asking for menu choices for this object.
;; Get back list of strings.
;; 2. Let used choose
;; 3. Call back to execute menu choice, passing nth and string of choice
(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
"Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
(let* ((what (slime-presentation-id presentation))
(choices (with-current-buffer buffer
(slime-eval
`(swank::menu-choices-for-presentation-id ',what)))))
(cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
(let ((sym (cl-gensym)))
(setf (gethash sym choice-to-lambda) f)
sym)))
(etypecase choices
(list
`(,(format "Presentation %s" (truncate-string-to-width
(slime-presentation-text presentation)
30 nil nil t))
(""
("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
,@(unless buffer-read-only
`(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
,@(let ((nchoice 0))
(mapcar
(lambda (choice)
(incf nchoice)
(cons choice
(savel `(lambda ()
(interactive)
(slime-eval
'(swank::execute-menu-choice-for-presentation-id
',what ,nchoice ,(nth (1- nchoice) choices)))))))
choices)))))
(symbol ; not-present
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))
(sit-for 0) ; allow redisplay
`("Object no longer recorded"
("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))
(defun slime-presentation-menu (event)
(interactive "e")
(let* ((point (if (featurep 'xemacs) (event-point event)
(posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event)))
(buffer (window-buffer window))
(choice-to-lambda (make-hash-table)))
(multiple-value-bind (presentation from to)
(with-current-buffer buffer
(slime-presentation-around-point point))
(unless presentation
(error "No presentation at event position"))
(let ((menu (slime-menu-choices-for-presentation
presentation buffer from to choice-to-lambda)))
(let ((choice (x-popup-menu event menu)))
(when choice
(call-interactively (gethash choice choice-to-lambda))))))))
(defun slime-presentation-expression (presentation)
"Return a string that contains a CL s-expression accessing
the presented object."
(let ((id (slime-presentation-id presentation)))
(etypecase id
(number
;; Make sure it works even if *read-base* is not 10.
(format "(swank:lookup-presented-object-or-lose %d.)" id))
(list
;; for frame variables and inspector parts
(format "(swank:lookup-presented-object-or-lose '%s)" id)))))
(defun slime-buffer-substring-with-reified-output (start end)
(let ((str-props (buffer-substring start end))
(str-no-props (buffer-substring-no-properties start end)))
(slime-reify-old-output str-props str-no-props)))
(defun slime-reify-old-output (str-props str-no-props)
(let ((pos (slime-property-position 'slime-repl-presentation str-props)))
(if (null pos)
str-no-props
(multiple-value-bind (presentation start-pos end-pos whole-p)
(slime-presentation-around-point pos str-props)
(if (not presentation)
str-no-props
(concat (substring str-no-props 0 pos)
;; Eval in the reader so that we play nice with quote.
;; -luke (19/May/2005)
"#." (slime-presentation-expression presentation)
(slime-reify-old-output (substring str-props end-pos)
(substring str-no-props end-pos))))))))
(defun slime-repl-grab-old-output (replace)
"Resend the old REPL output at point.
If replace it non-nil the current input is replaced with the old
output; otherwise the new input is appended."
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
(slime-check-presentation beg end (current-buffer) presentation)
(let ((old-output (buffer-substring beg end))) ;;keep properties
;; Append the old input or replace the current input
(cond (replace (goto-char slime-repl-input-start-mark))
(t (goto-char (point-max))
(unless (eq (char-before) ?\ )
(insert " "))))
(delete-region (point) (point-max))
(let ((inhibit-read-only t))
(insert old-output)))))
;;; Presentation-related key bindings, non-context menu
(defvar slime-presentation-command-map nil
"Keymap for presentation-related commands. Bound to a prefix key.")
(defvar slime-presentation-bindings
'((?i slime-inspect-presentation-at-point)
(?d slime-describe-presentation-at-point)
(?w slime-copy-presentation-at-point-to-kill-ring)
(?r slime-copy-presentation-at-point-to-repl)
(?p slime-previous-presentation)
(?n slime-next-presentation)
(?\ slime-mark-presentation)))
(defun slime-presentation-init-keymaps ()
(slime-init-keymap 'slime-presentation-command-map nil t
slime-presentation-bindings)
(define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
;; C-c C-v is the prefix for the presentation-command map.
(define-key slime-prefix-map "\C-v" slime-presentation-command-map))
(defun slime-presentation-around-or-before-point-p ()
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
presentation))
(defvar slime-presentation-easy-menu
(let ((P '(slime-presentation-around-or-before-point-p)))
`("Presentations"
[ "Find Definition" slime-M-.-presentation-at-point ,P ]
[ "Inspect" slime-inspect-presentation-at-point ,P ]
[ "Describe" slime-describe-presentation-at-point ,P ]
[ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
[ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
[ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
[ "Mark" slime-mark-presentation ,P ]
"--"
[ "Previous presentation" slime-previous-presentation ]
[ "Next presentation" slime-next-presentation ]
"--"
[ "Clear all presentations" slime-clear-presentations ])))
(defun slime-presentation-add-easy-menu ()
(easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
(easy-menu-add slime-presentation-easy-menu 'sldb-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map))
;;; hook functions (hard to isolate stuff)
(defun slime-dispatch-presentation-event (event)
(slime-dcase event
((:presentation-start id &optional target)
(slime-mark-presentation-start id target)
t)
((:presentation-end id &optional target)
(slime-mark-presentation-end id target)
t)
(t nil)))
(defun slime-presentation-write-result (string)
(with-current-buffer (slime-output-buffer)
(let ((marker (slime-repl-output-target-marker :repl-result))
(saved-point (point-marker)))
(goto-char marker)
(slime-propertize-region `(face slime-repl-result-face
rear-nonsticky (face))
(insert string))
;; Move the input-start marker after the REPL result.
(set-marker marker (point))
(set-marker slime-output-end (point))
;; Restore point before insertion but only it if was farther
;; than `marker'. Omitting this breaks REPL test
;; `repl-type-ahead'.
(when (> saved-point (point))
(goto-char saved-point)))
(slime-repl-show-maximum-output)))
(defun slime-presentation-write (string &optional target)
(case target
((nil) ; Regular process output
(slime-repl-emit string))
(:repl-result
(slime-presentation-write-result string))
(t (slime-repl-emit-to-target string target))))
(defun slime-presentation-current-input (&optional until-point-p)
"Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. Presentations of old results are expanded into code."
(slime-buffer-substring-with-reified-output slime-repl-input-start-mark
(if until-point-p
(point)
(point-max))))
(defun slime-presentation-on-return-pressed (end-of-input)
(when (and (car (slime-presentation-around-or-before-point (point)))
(< (point) slime-repl-input-start-mark))
(slime-repl-grab-old-output end-of-input)
(slime-repl-recenter-if-needed)
t))
(defun slime-presentation-bridge-insert (process output)
(slime-output-filter process (or output "")))
(defun slime-presentation-on-stream-open (stream)
(install-bridge)
(setq bridge-insert-function #'slime-presentation-bridge-insert)
(setq bridge-destination-insert nil)
(setq bridge-source-insert nil)
(setq bridge-handlers
(list* '("<" . slime-mark-presentation-start-handler)
'(">" . slime-mark-presentation-end-handler)
bridge-handlers)))
(defun slime-clear-presentations ()
"Forget all objects associated to SLIME presentations.
This allows the garbage collector to remove these objects
even on Common Lisp implementations without weak hash tables."
(interactive)
(slime-eval-async `(swank:clear-repl-results))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(slime-for-each-presentation-in-region 1 (1+ (buffer-size))
(lambda (presentation from to whole-p)
(slime-remove-presentation-properties from to
presentation))))
(defun slime-presentation-inspector-insert-ispec (ispec)
(if (stringp ispec)
(insert ispec)
(slime-dcase ispec
((:value string id)
(slime-propertize-region
(list 'slime-part-number id
'mouse-face 'highlight
'face 'slime-inspector-value-face)
(slime-insert-presentation string `(:inspected-part ,id) t)))
((:label string)
(insert (slime-inspector-fontify label string)))
((:action string id)
(slime-insert-propertized (list 'slime-action-number id
'mouse-face 'highlight
'face 'slime-inspector-action-face)
string)))))
(defun slime-presentation-sldb-insert-frame-variable-value (value frame index)
(slime-insert-presentation
(sldb-in-face local-value value)
`(:frame-var ,slime-current-thread ,(car frame) ,index) t))
(defun slime-presentations-on-connected ()
(slime-eval-async `(swank:init-presentations)))
(provide 'slime-presentations)

51
sbcl/.quicklisp/dists/quicklisp/software/slime-v2.24/contrib/slime-quicklisp.el Normal file
View file

@ -0,0 +1,51 @@
(require 'slime)
(require 'cl-lib)
;;; bits of the following taken from slime-asdf.el
(define-slime-contrib slime-quicklisp
"Quicklisp support."
(:authors "Matthew Kennedy <burnsidemk@gmail.com>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-quicklisp))
;;; Utilities
(defgroup slime-quicklisp nil
"Quicklisp support for Slime."
:prefix "slime-quicklisp-"
:group 'slime)
(defvar slime-quicklisp-system-history nil
"History list for Quicklisp system names.")
(defun slime-read-quicklisp-system-name (&optional prompt default-value)
"Read a Quick system name from the minibuffer, prompting with PROMPT."
(let* ((completion-ignore-case nil)
(prompt (or prompt "Quicklisp system"))
(quicklisp-system-names (slime-eval `(swank:list-quicklisp-systems)))
(prompt (concat prompt (if default-value
(format " (default `%s'): " default-value)
": "))))
(completing-read prompt (slime-bogus-completion-alist quicklisp-system-names)
nil nil nil
'slime-quicklisp-system-history default-value)))
(defun slime-quicklisp-quickload (system)
"Load a Quicklisp system."
(slime-save-some-lisp-buffers)
(slime-display-output-buffer)
(slime-repl-shortcut-eval-async `(ql:quickload ,system)))
;;; REPL shortcuts
(defslime-repl-shortcut slime-repl-quicklisp-quickload ("quicklisp-quickload" "ql")
(:handler (lambda ()
(interactive)
(slime-quicklisp-quickload (slime-read-quicklisp-system-name))))
(:one-liner "Load a system known to Quicklisp."))
(provide 'slime-quicklisp)

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